LambdaHack-0.5.0.0/0000755000000000000000000000000012555256425012022 5ustar0000000000000000LambdaHack-0.5.0.0/CHANGELOG.md0000644000000000000000000001703212555256425013636 0ustar0000000000000000## [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 - add a simple cabal test in addition to make-test and travis-test - generate items and actors according to their rarities at various depths - redo weapon choice, combat bonuses and introduce armor - introduce skill levels for abilities (boolean for now, WIP) - remove regeneration, re-add through periodically activating items - ensure passable areas of randomly filled caves are well connected - make secondary factions leaderless - auto-tweak digital line epsilon to let projectiles evade obstacles - add shrapnel (explosions) and organs (body parts) - express actor kinds as item kinds (their trunk) - add dynamic lights through items, actors, projectiles - fix and improve item kind and item stats identification - make aspects additive from all equipment and organ items - split item effects into aspects, effects and item features - rework AI and structure it according to the Ability type - define Num instance for Dice to make writing it in content easier - remove the shared screen multiplayer mode and all support code, for now - rename all modules and nearly all other code entities - check and consume HP when calling friends and Calm when summoning - determine sight radius from items and cap it at current Calm/5 - introduce Calm; use to hear nearby enemies and limit item abuse before death - let AI actors manage items and share them with party members - completely revamp item manipulation UI - add a command to cede control to AI - separate actor inventory, 10-item actor equipment and shared party stash - vi movement keys (hjklyubn) are now disabled by default - new movement keyset: laptop movement keys (uk8o79jl) ## [v0.2.12](https://github.com/LambdaHack/LambdaHack/compare/v0.2.10...v0.2.12) - improve and simplify dungeon generation - simplify running and permit multi-actor runs - let items explode and generate shrapnel projectiles - add game difficulty setting (initial HP scaling right now) - allow recording, playing back and looping commands - implement pathfinding via per-actor BFS over the whole level - extend setting targets for actors in UI tremendously - implement autoexplore, go-to-target, etc., as macros - let AI use pathfinding, switch leaders, pick levels to swarm to - force level/leader changes on spawners (even when played by humans) - extend and redesign UI bottom status lines - get rid of CPS style monads, aborts and WriterT - benchmark and optimize the code, in particular using Data.Vector - split off and use the external library assert-failure - simplify config files and limit the number of external dependencies ## [v0.2.10](https://github.com/LambdaHack/LambdaHack/compare/v0.2.8...v0.2.10) - screensaver game modes (AI vs AI) - improved AI (can now climbs stairs, etc.) - multiple, multi-floor staircases - multiple savefiles - configurable framerate and combat animations ## [v0.2.8](https://github.com/LambdaHack/LambdaHack/compare/v0.2.6.5...v0.2.8) - cooperative and competitive multiplayer (shared-screen only in this version) - overhauled searching - rewritten engine code to have a single server that sends restricted game state updates to many fat clients, while a thin frontend layer multiplexes visuals from a subset of the clients ## [v0.2.6.5](https://github.com/LambdaHack/LambdaHack/compare/v0.2.6...v0.2.6.5) - this is a minor release, primarily intended to fix the broken haddock documentation on Hackage - changes since 0.2.6 are mostly unrelated to gameplay: - strictly typed config files split into UI and rules - a switch from Text to String throughout the codebase - use of the external library miniutter for English sentence generation ## [v0.2.6](https://github.com/LambdaHack/LambdaHack/compare/v0.2.1...v0.2.6) - the Main Menu - improved and configurable mode of squad combat ## [v0.2.1](https://github.com/LambdaHack/LambdaHack/compare/v0.2.0...v0.2.1) - missiles flying for three turns (by an old kosmikus' idea) - visual feedback for targeting - animations of combat and individual monster moves ## [v0.2.0](https://github.com/LambdaHack/LambdaHack/compare/release-0.1.20110918...v0.2.6) - the LambdaHack engine becomes a Haskell library - the LambdaHack game depends on the engine library LambdaHack-0.5.0.0/CREDITS0000644000000000000000000000027212555256425013043 0ustar0000000000000000All kinds of contributions to the LambdaHack engine are gratefully welcome! Some of the contributors are listed below, in chronological order. Andres Loeh Mikolaj Konarski Tuukka Turto LambdaHack-0.5.0.0/LICENSE0000644000000000000000000000273312555256425013034 0ustar0000000000000000Copyright (c) 2008--2015 Andres Loeh Copyright (c) 2010--2015 Mikolaj Konarski 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. 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 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. LambdaHack-0.5.0.0/Setup.hs0000644000000000000000000000005712555256425013460 0ustar0000000000000000import Distribution.Simple main = defaultMain LambdaHack-0.5.0.0/README.md0000644000000000000000000002100112555256425013273 0ustar0000000000000000LambdaHack [![Build Status](https://travis-ci.org/LambdaHack/LambdaHack.svg?branch=master)](https://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 is a [Haskell] [1] game engine library for [roguelike] [2] games of arbitrary theme, size and complexity. You specify the content to be procedurally generated, including game rules and AI behaviour. The library lets you 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. The engine comes with a sample code for a little dungeon crawler, called LambdaHack and described in [PLAYING.md](GameDefinition/PLAYING.md). ![gameplay screenshot](https://raw.githubusercontent.com/LambdaHack/media/master/screenshot/raid1.png) Other games known to use the LambdaHack library: * [Allure of the Stars] [6], a near-future Sci-Fi game * [Space Privateers] [8], an adventure game set in far future Note: the engine and the example 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-only 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] or any other pure game content package and mix and merge with the example 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). Installation from binary archives --------------------------------- Pre-compiled game binaries for some platforms are available through the [release page] [11] and from the [Nix Packages Collection] [12]. To manually install a binary archive, make sure you have the GTK libraries suite on your system, unpack the LambdaHack archive and run the executable in the unpacked directory. On Windows, if you don't already have GTK installed (e.g., for the GIMP picture editor) please download and run (with default settings) the GTK installer from http://sourceforge.net/projects/gtk-win/ Screen and keyboard configuration --------------------------------- The game UI can be configured via a config file. A file with the default settings, the same as built into the binary, is in [GameDefinition/config.ui.default](GameDefinition/config.ui.default). When the game is run for the first time, the file is copied to the official location, which is `~/.LambdaHack/config.ui.ini` on Linux and `C:\Users\\AppData\Roaming\LambdaHack\config.ui.ini` (or `C:\Documents And Settings\user\Application Data\LambdaHack\config.ui.ini` or something else altogether) on Windows. Screen font can be changed and enlarged by editing the config file at its official location or by CTRL-right-clicking on the game window. If you use the numeric keypad, use the NumLock key on your keyboard to toggle the game keyboard mode. With NumLock off, you walk with the numeric keys and run with SHIFT (or CONTROL) and the keys. This mode is probably the best if you use mouse for running. When you turn NumLock on, the reversed key setup enforces good playing habits by setting as the default the run command (which automatically stops at threats, keeping you safe) and requiring SHIFT (or CONTROL) for the error-prone step by step walking. If you don't have the numeric keypad, you can use laptop keys (uk8o79jl) or you can enable the Vi keys (aka roguelike keys) in the config file. Compilation from source ----------------------- If you want to compile your own binaries from the source code, use Cabal (already a part of your OS distribution, or available within [The Haskell Platform] [7]), which also takes care of all the dependencies. You also need the GTK libraries for your OS. On Linux, remember to install the -dev versions as well. On Windows follow [the same steps as for Wine] [13]. On OSX, if you encounter problems, you may want to [compile the GTK libraries from sources] [14]. The latest official version of the library can be downloaded, compiled and installed automatically by Cabal from [Hackage] [3] as follows cabal update cabal install gtk2hs-buildtools cabal install LambdaHack --force-reinstalls For a newer snapshot, download source from a development branch at [github] [5] and run Cabal from the main directory cabal install gtk2hs-buildtools cabal install --force-reinstalls 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, cabal install -fvty --force-reinstalls Compatibility notes ------------------- If you are using a terminal frontend, numeric 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 started in an xterm, CTRL-keypad keys for running seem to work OK, but on rxvt they do not. The commands that require pressing CTRL and SHIFT together won't work either, but fortunately they are not crucial to gameplay. For movement, laptop (uk8o79jl) and Vi keys (hjklyubn, if enabled in config.ui.ini) should work everywhere. GTK works fine, too, both with numeric keypad and with mouse. Testing and debugging --------------------- The [Makefile](Makefile) contains many sample test commands. Numerous tests 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 gtk frontend. 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). You can use HPC with the game as follows (details vary according to HPC version). 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-coverage make test hpc report --hpcdir=dist/hpc/dyn/mix/LambdaHack --hpcdir=dist/hpc/dyn/mix/LambdaHack-xxx/ LambdaHack hpc markup --hpcdir=dist/hpc/dyn/mix/LambdaHack --hpcdir=dist/hpc/dyn/mix/LambdaHack-xxx/ LambdaHack Note that debug option `--stopAfter` is required to cleanly terminate any automated test. This is needed to gather any HPC info, because HPC requires a clean exit to save data files. Further information ------------------- For more information, visit the [wiki] [4] and see [PLAYING.md](GameDefinition/PLAYING.md), [CREDITS](CREDITS) and [LICENSE](LICENSE). Have fun! [1]: http://www.haskell.org/ [2]: http://roguebasin.roguelikedevelopment.org/index.php?title=Berlin_Interpretation [3]: http://hackage.haskell.org/package/LambdaHack [4]: https://github.com/LambdaHack/LambdaHack/wiki [5]: http://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/latest [12]: http://hydra.cryp.to/search?query=LambdaHack [13]: http://www.haskell.org/haskellwiki/GHC_under_Wine#Code_that_uses_gtk2hs [14]: http://www.edsko.net/2014/04/27/haskell-including-gtk-on-mavericks LambdaHack-0.5.0.0/LambdaHack.cabal0000644000000000000000000004667612555256425015000 0ustar0000000000000000name: 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 -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change version: 0.5.0.0 synopsis: A game engine library for roguelike dungeon crawlers description: LambdaHack is a game engine library for roguelike 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 from the content and of clients (human and AI-controlled) from the 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. . Games known to use the LambdaHack library: . * Allure of the Stars, a near-future Sci-Fi game, . * Space Privateers, an adventure game set in far future, . 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. homepage: http://github.com/LambdaHack/LambdaHack bug-reports: http://github.com/LambdaHack/LambdaHack/issues license: BSD3 license-file: LICENSE tested-with: GHC == 7.6, GHC == 7.8, GHC == 7.10 data-files: GameDefinition/config.ui.default, GameDefinition/scores GameDefinition/PLAYING.md, README.md, LICENSE, CREDITS, CHANGELOG.md extra-source-files: GameDefinition/MainMenu.ascii, Makefile author: Andres Loeh, Mikolaj Konarski maintainer: Mikolaj Konarski 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 default: False manual: True flag curses description: switch to the curses frontend (not fully supported) default: False manual: True flag expose_internal description: expose internal functions and types, but don't switch on any other release mode options default: False manual: True flag with_expensive_assertions description: turn on expensive assertions of well-tested code default: False manual: True flag release description: prepare for a release (expose, optimize, 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.EffectDescription, Game.LambdaHack.Common.Faction, 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.RingBuffer, 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.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.3.0 && < 1, data-default, 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.4 && < 2, mtl >= 2.0.1 && < 3, old-time >= 1.0.0.7 && < 2, pretty-show >= 1.6 && < 2, random >= 1.1 && < 2, stm >= 2.4 && < 3, text >= 0.11.2.3 && < 2, transformers >= 0.3 && < 1, unordered-containers >= 0.2.3 && < 1, vector >= 0.10 && < 1, vector-binary-instances >= 0.2 && < 1, zlib >= 0.5.3.1 && < 1 default-language: Haskell2010 default-extensions: MonoLocalBinds, ScopedTypeVariables, OverloadedStrings BangPatterns, RecordWildCards, NamedFieldPuns other-extensions: CPP, 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 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 >= 5 && < 6 cpp-options: -DVTY } else { if impl(ghc > 7.8) { other-modules: Game.LambdaHack.Client.UI.Frontend.Gtk build-depends: gtk >= 0.12.1 && < 0.14 pkgconfig-depends: gtk+-2.0 } else { other-modules: Game.LambdaHack.Client.UI.Frontend.Gtk build-depends: gtk >= 0.12.1 && < 0.13 pkgconfig-depends: gtk+-2.0 } } } if flag(expose_internal) cpp-options: -DEXPOSE_INTERNAL if flag(with_expensive_assertions) cpp-options: -DWITH_EXPENSIVE_ASSERTIONS if flag(release) { cpp-options: -DEXPOSE_INTERNAL -- 7.6.3 has broken -O2, apparently if impl(ghc > 7.8) ghc-options: -O2 -fno-ignore-asserts } executable LambdaHack hs-source-dirs: GameDefinition main-is: Main.hs other-modules: Client.UI.Content.KeyKind, Content.CaveKind, Content.ItemKind, Content.ItemKindActor, Content.ItemKindOrgan, Content.ItemKindBlast, Content.ItemKindTemporary, Content.ModeKind, Content.ModeKindPlayer, Content.PlaceKind, Content.RuleKind, Content.TileKind, TieKnot, Paths_LambdaHack build-depends: LambdaHack, template-haskell >= 2.6 && < 3, 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.3.0 && < 1, data-default, 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.4 && < 2, mtl >= 2.0.1 && < 3, old-time >= 1.0.0.7 && < 2, pretty-show >= 1.6 && < 2, random >= 1.1 && < 2, stm >= 2.4 && < 3, text >= 0.11.2.3 && < 2, transformers >= 0.3 && < 1, unordered-containers >= 0.2.3 && < 1, vector >= 0.10 && < 1, vector-binary-instances >= 0.2 && < 1, zlib >= 0.5.3.1 && < 1 default-language: Haskell2010 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 if flag(release) ghc-options: -O2 -fno-ignore-asserts "-with-rtsopts=-N1" -- TODO: -N 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, 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.3.0 && < 1, data-default, 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.4 && < 2, mtl >= 2.0.1 && < 3, old-time >= 1.0.0.7 && < 2, pretty-show >= 1.6 && < 2, random >= 1.1 && < 2, stm >= 2.4 && < 3, text >= 0.11.2.3 && < 2, transformers >= 0.3 && < 1, unordered-containers >= 0.2.3 && < 1, vector >= 0.10 && < 1, vector-binary-instances >= 0.2 && < 1, zlib >= 0.5.3.1 && < 1 default-language: Haskell2010 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 if flag(release) ghc-options: -O2 -fno-ignore-asserts "-with-rtsopts=-N1" -- TODO: -N LambdaHack-0.5.0.0/Makefile0000644000000000000000000004347312555256425013475 0ustar0000000000000000# All xc* tests assume a profiling build (for stack traces). # See the install-debug target below. install-debug: cabal install --enable-library-profiling --enable-executable-profiling --ghc-options="-fprof-auto-calls" --disable-optimization configure-debug: cabal configure --enable-library-profiling --enable-executable-profiling --ghc-options="-fprof-auto-calls" --disable-optimization xcplay: dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --dumpInitRngs xcfrontendCampaign: dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame 1 --maxFps 60 --dumpInitRngs --automateAll --gameMode campaign xcfrontendRaid: dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame 5 --maxFps 60 --dumpInitRngs --automateAll --gameMode raid xcfrontendSkirmish: dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame 5 --maxFps 60 --dumpInitRngs --automateAll --gameMode skirmish xcfrontendAmbush: dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame 5 --maxFps 60 --dumpInitRngs --automateAll --gameMode ambush xcfrontendBattle: dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame 2 --maxFps 60 --dumpInitRngs --automateAll --gameMode battle xcfrontendBattleSurvival: dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame 8 --maxFps 60 --dumpInitRngs --automateAll --gameMode "battle survival" xcfrontendSafari: dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame 2 --maxFps 60 --dumpInitRngs --automateAll --gameMode safari xcfrontendSafariSurvival: dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame 8 --maxFps 60 --dumpInitRngs --automateAll --gameMode "safari survival" xcfrontendDefense: dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame 9 --maxFps 60 --dumpInitRngs --automateAll --gameMode defense play: dist/build/LambdaHack/LambdaHack --dbgMsgSer --dumpInitRngs frontendCampaign: dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame 1 --maxFps 60 --dumpInitRngs --automateAll --gameMode campaign frontendRaid: dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame 5 --maxFps 60 --dumpInitRngs --automateAll --gameMode raid frontendSkirmish: dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame 5 --maxFps 60 --dumpInitRngs --automateAll --gameMode skirmish frontendAmbush: dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame 5 --maxFps 60 --dumpInitRngs --automateAll --gameMode ambush frontendBattle: dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame 2 --maxFps 60 --dumpInitRngs --automateAll --gameMode battle frontendBattleSurvival: dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame 8 --maxFps 60 --dumpInitRngs --automateAll --gameMode "battle survival" frontendSafari: dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame 2 --maxFps 60 --dumpInitRngs --automateAll --gameMode safari frontendSafariSurvival: dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame 8 --maxFps 60 --dumpInitRngs --automateAll --gameMode "safari survival" frontendDefense: dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame 9 --maxFps 60 --dumpInitRngs --automateAll --gameMode defense benchCampaign: dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame 1 --noDelay --noAnim --maxFps 100000 --frontendNull --benchmark --stopAfter 60 --automateAll --keepAutomated --gameMode campaign --setDungeonRng 42 --setMainRng 42 +RTS -N1 -RTS benchBattle: dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame 2 --noDelay --noAnim --maxFps 100000 --frontendNull --benchmark --stopAfter 60 --automateAll --keepAutomated --gameMode battle --setDungeonRng 42 --setMainRng 42 +RTS -N1 -RTS benchFrontendCampaign: dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame 1 --maxFps 100000 --benchmark --stopAfter 60 --automateAll --keepAutomated --gameMode campaign --setDungeonRng 42 --setMainRng 42 +RTS -N1 -RTS benchFrontendBattle: dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame 2 --maxFps 100000 --benchmark --stopAfter 60 --automateAll --keepAutomated --gameMode battle --setDungeonRng 42 --setMainRng 42 +RTS -N1 -RTS benchNull: benchCampaign benchBattle bench: benchCampaign benchFrontendCampaign benchBattle benchFrontendBattle test-travis-short: test-short test-travis-medium: test-short test-medium test-travis-medium-no-safari: test-short test-medium-no-safari test-travis-long: test-short test-long test-travis-long-no-safari: test-short test-long-no-safari test: test-short test-medium test-long test-short: test-short-new test-short-load test-medium: testCampaign-medium testRaid-medium testSkirmish-medium testAmbush-medium testBattle-medium testBattleSurvival-medium testSafari-medium testSafariSurvival-medium testPvP-medium testCoop-medium testDefense-medium test-medium-no-safari: testCampaign-medium testRaid-medium testSkirmish-medium testAmbush-medium testBattle-medium testBattleSurvival-medium testPvP-medium testCoop-medium testDefense-medium test-long: testCampaign-long testRaid-medium testSkirmish-medium testAmbush-medium testBattle-long testBattleSurvival-long testSafari-long testSafariSurvival-long testPvP-medium testDefense-long test-long-no-safari: testCampaign-long testRaid-medium testSkirmish-medium testAmbush-medium testBattle-long testBattleSurvival-long testPvP-medium testDefense-long testCampaign-long: dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame 1 --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 500 --dumpInitRngs --automateAll --keepAutomated --gameMode campaign > /tmp/stdtest.log testCampaign-medium: dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame 1 --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 400 --dumpInitRngs --automateAll --keepAutomated --gameMode campaign > /tmp/stdtest.log testRaid-long: dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame 5 --maxFps 100000 --frontendStd --benchmark --stopAfter 60 --dumpInitRngs --automateAll --keepAutomated --gameMode raid > /tmp/stdtest.log testRaid-medium: dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame 5 --maxFps 100000 --frontendStd --benchmark --stopAfter 30 --dumpInitRngs --automateAll --keepAutomated --gameMode raid > /tmp/stdtest.log testSkirmish-long: dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame 5 --maxFps 100000 --frontendStd --benchmark --stopAfter 60 --dumpInitRngs --automateAll --keepAutomated --gameMode skirmish > /tmp/stdtest.log testSkirmish-medium: dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame 5 --maxFps 100000 --frontendStd --benchmark --stopAfter 30 --dumpInitRngs --automateAll --keepAutomated --gameMode skirmish > /tmp/stdtest.log testAmbush-long: dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame 5 --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 60 --dumpInitRngs --automateAll --keepAutomated --gameMode ambush > /tmp/stdtest.log testAmbush-medium: dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame 5 --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 30 --dumpInitRngs --automateAll --keepAutomated --gameMode ambush > /tmp/stdtest.log testBattle-long: dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame 2 --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 100 --dumpInitRngs --automateAll --keepAutomated --gameMode battle > /tmp/stdtest.log testBattle-medium: dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame 2 --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 50 --dumpInitRngs --automateAll --keepAutomated --gameMode battle > /tmp/stdtest.log testBattleSurvival-long: dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame 8 --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 100 --dumpInitRngs --automateAll --keepAutomated --gameMode "battle survival" > /tmp/stdtest.log testBattleSurvival-medium: dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame 8 --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 50 --dumpInitRngs --automateAll --keepAutomated --gameMode "battle survival" > /tmp/stdtest.log testSafari-long: dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame 2 --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 250 --dumpInitRngs --automateAll --keepAutomated --gameMode safari > /tmp/stdtest.log testSafari-medium: dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame 2 --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 200 --dumpInitRngs --automateAll --keepAutomated --gameMode safari > /tmp/stdtest.log testSafariSurvival-long: dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame 8 --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 250 --dumpInitRngs --automateAll --keepAutomated --gameMode "safari survival" > /tmp/stdtest.log testSafariSurvival-medium: dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame 8 --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 200 --dumpInitRngs --automateAll --keepAutomated --gameMode "safari survival" > /tmp/stdtest.log testPvP-long: dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame 5 --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 60 --dumpInitRngs --automateAll --keepAutomated --gameMode PvP > /tmp/stdtest.log testPvP-medium: dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame 5 --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 30 --dumpInitRngs --automateAll --keepAutomated --gameMode PvP > /tmp/stdtest.log testCoop-long: dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame 2 --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 500 --dumpInitRngs --automateAll --keepAutomated --gameMode Coop > /tmp/stdtest.log testCoop-medium: dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame 2 --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 300 --dumpInitRngs --automateAll --keepAutomated --gameMode Coop > /tmp/stdtest.log testDefense-long: dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame 9 --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 500 --dumpInitRngs --automateAll --keepAutomated --gameMode defense > /tmp/stdtest.log testDefense-medium: dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame 9 --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 300 --dumpInitRngs --automateAll --keepAutomated --gameMode defense > /tmp/stdtest.log test-short-new: dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame 5 --savePrefix campaign --dumpInitRngs --automateAll --keepAutomated --gameMode campaign --frontendStd --stopAfter 2 > /tmp/stdtest.log dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame 5 --savePrefix raid --dumpInitRngs --automateAll --keepAutomated --gameMode raid --frontendStd --stopAfter 2 > /tmp/stdtest.log dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame 5 --savePrefix skirmish --dumpInitRngs --automateAll --keepAutomated --gameMode skirmish --frontendStd --stopAfter 2 > /tmp/stdtest.log dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame 5 --savePrefix ambush --dumpInitRngs --automateAll --keepAutomated --gameMode ambush --frontendStd --stopAfter 2 > /tmp/stdtest.log dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame 5 --savePrefix battle --dumpInitRngs --automateAll --keepAutomated --gameMode battle --frontendStd --stopAfter 2 > /tmp/stdtest.log dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame 5 --savePrefix battleSurvival --dumpInitRngs --automateAll --keepAutomated --gameMode "battle survival" --frontendStd --stopAfter 2 > /tmp/stdtest.log dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame 5 --savePrefix safari --dumpInitRngs --automateAll --keepAutomated --gameMode safari --frontendStd --stopAfter 2 > /tmp/stdtest.log dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame 5 --savePrefix safariSurvival --dumpInitRngs --automateAll --keepAutomated --gameMode "safari survival" --frontendStd --stopAfter 2 > /tmp/stdtest.log dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame 5 --savePrefix PvP --dumpInitRngs --automateAll --keepAutomated --gameMode PvP --frontendStd --stopAfter 2 > /tmp/stdtest.log dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame 5 --savePrefix Coop --dumpInitRngs --automateAll --keepAutomated --gameMode Coop --frontendStd --stopAfter 2 > /tmp/stdtest.log dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame 5 --savePrefix defense --dumpInitRngs --automateAll --keepAutomated --gameMode defense --frontendStd --stopAfter 2 > /tmp/stdtest.log test-short-load: dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix campaign --dumpInitRngs --automateAll --keepAutomated --gameMode campaign --frontendStd --stopAfter 2 > /tmp/stdtest.log dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix raid --dumpInitRngs --automateAll --keepAutomated --gameMode raid --frontendStd --stopAfter 2 > /tmp/stdtest.log dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix skirmish --dumpInitRngs --automateAll --keepAutomated --gameMode skirmish --frontendStd --stopAfter 2 > /tmp/stdtest.log dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix ambush --dumpInitRngs --automateAll --keepAutomated --gameMode ambush --frontendStd --stopAfter 2 > /tmp/stdtest.log dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix battle --dumpInitRngs --automateAll --keepAutomated --gameMode battle --frontendStd --stopAfter 2 > /tmp/stdtest.log dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix battleSurvival --dumpInitRngs --automateAll --keepAutomated --gameMode "battle survival" --frontendStd --stopAfter 2 > /tmp/stdtest.log dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix safari --dumpInitRngs --automateAll --keepAutomated --gameMode safari --frontendStd --stopAfter 2 > /tmp/stdtest.log dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix safariSurvival --dumpInitRngs --automateAll --keepAutomated --gameMode "safari survival" --frontendStd --stopAfter 2 > /tmp/stdtest.log dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix PvP --dumpInitRngs --automateAll --keepAutomated --gameMode PvP --frontendStd --stopAfter 2 > /tmp/stdtest.log dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix Coop --dumpInitRngs --automateAll --keepAutomated --gameMode Coop --frontendStd --stopAfter 2 > /tmp/stdtest.log dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix defense --dumpInitRngs --automateAll --keepAutomated --gameMode defense --frontendStd --stopAfter 2 > /tmp/stdtest.log build-binary: cabal configure -frelease --prefix=/ cabal build exe:LambdaHack rm -rf /tmp/LambdaHack_x_ubuntu-12.04-amd64.tar.gz rm -rf /tmp/LambdaHackTheGameInstall rm -rf /tmp/LambdaHackTheGame mkdir -p /tmp/LambdaHackTheGame/GameDefinition cabal copy --destdir=/tmp/LambdaHackTheGameInstall cp /tmp/LambdaHackTheGameInstall/bin/LambdaHack /tmp/LambdaHackTheGame cp GameDefinition/PLAYING.md /tmp/LambdaHackTheGame/GameDefinition cp GameDefinition/scores /tmp/LambdaHackTheGame/GameDefinition cp GameDefinition/config.ui.default /tmp/LambdaHackTheGame/GameDefinition cp CHANGELOG.md /tmp/LambdaHackTheGame cp CREDITS /tmp/LambdaHackTheGame cp LICENSE /tmp/LambdaHackTheGame cp README.md /tmp/LambdaHackTheGame tar -czf /tmp/LambdaHack_x_ubuntu-12.04-amd64.tar.gz -C /tmp LambdaHackTheGame build-binary-i386: cabal configure -frelease --prefix=/ --ghc-option="-optc-m32" --ghc-option="-opta-m32" --ghc-option="-optl-m32" --ld-option="-melf_i386" cabal build exe:LambdaHack rm -rf /tmp/LambdaHack_x_ubuntu-12.04-i386.tar.gz rm -rf /tmp/LambdaHackTheGameInstall rm -rf /tmp/LambdaHackTheGame mkdir -p /tmp/LambdaHackTheGame/GameDefinition cabal copy --destdir=/tmp/LambdaHackTheGameInstall cp /tmp/LambdaHackTheGameInstall/bin/LambdaHack /tmp/LambdaHackTheGame cp GameDefinition/PLAYING.md /tmp/LambdaHackTheGame/GameDefinition cp GameDefinition/scores /tmp/LambdaHackTheGame/GameDefinition cp GameDefinition/config.ui.default /tmp/LambdaHackTheGame/GameDefinition cp CHANGELOG.md /tmp/LambdaHackTheGame cp CREDITS /tmp/LambdaHackTheGame cp LICENSE /tmp/LambdaHackTheGame cp README.md /tmp/LambdaHackTheGame tar -czf /tmp/LambdaHack_x_ubuntu-12.04-i386.tar.gz -C /tmp LambdaHackTheGame # TODO: figure out, whey this must be so different from Linux build-binary-windows-i386: wine cabal configure -frelease wine cabal build exe:LambdaHack rm -rf /tmp/LambdaHack_x_windows-i386.zip rm -rf /tmp/LambdaHackTheGameInstall rm -rf /tmp/LambdaHackTheGame mkdir -p /tmp/LambdaHackTheGame/GameDefinition wine cabal copy --destdir=Z:/tmp/LambdaHackTheGameInstall cp /tmp/LambdaHackTheGameInstall/users/mikolaj/Application\ Data/cabal/bin/LambdaHack.exe /tmp/LambdaHackTheGame cp GameDefinition/PLAYING.md /tmp/LambdaHackTheGame/GameDefinition cp GameDefinition/scores /tmp/LambdaHackTheGame/GameDefinition cp GameDefinition/config.ui.default /tmp/LambdaHackTheGame/GameDefinition cp CHANGELOG.md /tmp/LambdaHackTheGame cp CREDITS /tmp/LambdaHackTheGame cp LICENSE /tmp/LambdaHackTheGame cp README.md /tmp/LambdaHackTheGame cp /home/mikolaj/.wine/drive_c/users/mikolaj/gtk/bin/zlib1.dll /tmp/LambdaHackTheGame wine Z:/home/mikolaj/.local/share/wineprefixes/7zip/drive_c/Program\ Files/7-Zip/7z.exe a -ssc -sfx Z:/tmp/LambdaHack_x_windows-i386.exe Z:/tmp/LambdaHackTheGame LambdaHack-0.5.0.0/Game/0000755000000000000000000000000012555256425012673 5ustar0000000000000000LambdaHack-0.5.0.0/Game/LambdaHack/0000755000000000000000000000000012555256425014642 5ustar0000000000000000LambdaHack-0.5.0.0/Game/LambdaHack/Client.hs0000644000000000000000000000067312555256425016422 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} -- | Semantics of responses that are sent to clients. -- -- See -- . module Game.LambdaHack.Client ( -- * Re-exported from "Game.LambdaHack.Client.LoopClient" loopAI, loopUI -- * Re-exported from "Game.LambdaHack.Client.UI" , srtFrontend ) where import Game.LambdaHack.Client.LoopClient import Game.LambdaHack.Client.UI LambdaHack-0.5.0.0/Game/LambdaHack/Atomic.hs0000644000000000000000000000130112555256425016405 0ustar0000000000000000-- | Atomic game state transformations. -- -- See -- . module Game.LambdaHack.Atomic ( -- * Re-exported from "Game.LambdaHack.Atomic.MonadAtomic" MonadAtomic(..) , broadcastUpdAtomic, broadcastSfxAtomic -- * Re-exported from "Game.LambdaHack.Atomic.CmdAtomic" , CmdAtomic(..), UpdAtomic(..), SfxAtomic(..), HitAtomic(..) -- * Re-exported from "Game.LambdaHack.Atomic.PosAtomicRead" , PosAtomic(..), posUpdAtomic, posSfxAtomic, seenAtomicCli, generalMoveItem , posProjBody ) where import Game.LambdaHack.Atomic.CmdAtomic import Game.LambdaHack.Atomic.MonadAtomic import Game.LambdaHack.Atomic.PosAtomicRead LambdaHack-0.5.0.0/Game/LambdaHack/Server.hs0000644000000000000000000000121012555256425016436 0ustar0000000000000000-- | Semantics of requests that are sent to the server. -- -- See -- . module Game.LambdaHack.Server ( -- * Re-exported from "Game.LambdaHack.Server.LoopServer" loopSer -- * Re-exported from "Game.LambdaHack.Server.MonadServer" , speedupCOps -- * Re-exported from "Game.LambdaHack.Server.Commandline" , debugArgs -- * Re-exported from "Game.LambdaHack.Server.State" , sdebugCli ) where import Game.LambdaHack.Server.Commandline import Game.LambdaHack.Server.LoopServer import Game.LambdaHack.Server.MonadServer import Game.LambdaHack.Server.State LambdaHack-0.5.0.0/Game/LambdaHack/Content/0000755000000000000000000000000012555256425016254 5ustar0000000000000000LambdaHack-0.5.0.0/Game/LambdaHack/Content/ItemKind.hs0000644000000000000000000002366112555256425020324 0ustar0000000000000000{-# LANGUAGE DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable #-} -- | The type of kinds of weapons, treasure, organs, blasts and actors. module Game.LambdaHack.Content.ItemKind ( ItemKind(..) , Effect(..), TimerDice(..) , Aspect(..), ThrowMod(..) , Feature(..), EqpSlot(..) , slotName , toVelocity, toLinger, toOrganGameTurn, toOrganActorTurn, toOrganNone , validateSingleItemKind, validateAllItemKind ) where import Control.DeepSeq import Data.Binary import Data.Foldable (Foldable) import Data.Hashable (Hashable) import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T import Data.Traversable (Traversable) import GHC.Generics (Generic) import qualified NLP.Miniutter.English as MU import qualified Game.LambdaHack.Common.Ability as Ability import qualified Game.LambdaHack.Common.Dice as Dice import Game.LambdaHack.Common.Flavour import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.Msg -- | Item properties that are fixed for a given kind of items. data ItemKind = ItemKind { isymbol :: !Char -- ^ map symbol , iname :: !Text -- ^ generic name , ifreq :: !(Freqs ItemKind) -- ^ frequency within groups , iflavour :: ![Flavour] -- ^ possible flavours , icount :: !Dice.Dice -- ^ created in that quantity , irarity :: !Rarity -- ^ rarity on given depths , iverbHit :: !MU.Part -- ^ the verb for applying and melee , iweight :: !Int -- ^ weight in grams , iaspects :: ![Aspect Dice.Dice] -- ^ keep the aspect continuously , ieffects :: ![Effect] -- ^ cause the effect when triggered , ifeature :: ![Feature] -- ^ public properties , idesc :: !Text -- ^ description , ikit :: ![(GroupName ItemKind, CStore)] -- ^ accompanying organs and items } deriving Show -- No Eq and Ord to make extending it logically sound -- 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. Constructors are sorted vs increasing impact/danger. data Effect = -- Ordinary effects. NoEffect !Text | Hurt !Dice.Dice | Burn !Dice.Dice -- TODO: generalize to other elements? ignite terrain? | Explode !(GroupName ItemKind) -- ^ explode, producing this group of blasts | RefillHP !Int | OverfillHP !Int | RefillCalm !Int | OverfillCalm !Int | Dominate | Impress | CallFriend !Dice.Dice | Summon !(Freqs ItemKind) !Dice.Dice | Ascend !Int | Escape !Int -- ^ the Int says if can be placed on last level, etc. | Paralyze !Dice.Dice | InsertMove !Dice.Dice | Teleport !Dice.Dice | CreateItem !CStore !(GroupName ItemKind) !TimerDice -- ^ create an item of the group and insert into -- the store with the given random timer | DropItem !CStore !(GroupName ItemKind) !Bool -- ^ @DropItem CGround x True@ means stomp on items | PolyItem | Identify | SendFlying !ThrowMod | PushActor !ThrowMod | PullActor !ThrowMod | DropBestWeapon | ActivateInv !Char -- ^ symbol @' '@ means all | ApplyPerfume -- Exotic effects follow. | OneOf ![Effect] | OnSmash !Effect -- ^ trigger if item smashed (not applied nor meleed) | Recharging !Effect -- ^ this effect inactive until timeout passes | Temporary !Text -- ^ the item is temporary, vanishes at even void -- Periodic activation, unless Durable deriving (Show, Read, Eq, Ord, Generic) instance NFData Effect data TimerDice = TimerNone | TimerGameTurn !Dice.Dice | TimerActorTurn !Dice.Dice deriving (Read, Eq, Ord, Generic) 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" instance NFData TimerDice -- | Aspects of items. Those that are named @Add*@ are additive -- (starting at 0) for all items wielded by an actor and they affect the actor. data Aspect a = Unique -- ^ at most one copy can ever be generated | Periodic -- ^ in equipment, apply as often as @Timeout@ permits | Timeout !a -- ^ some effects will be disabled until item recharges | AddHurtMelee !a -- ^ percentage damage bonus in melee | AddHurtRanged !a -- ^ percentage damage bonus in ranged | AddArmorMelee !a -- ^ percentage armor bonus against melee | 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, Foldable, Traversable) -- | 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) instance NFData ThrowMod -- | Features of item. Affect only the item in question, not the actor, -- and so not additive in any sense. data Feature = Fragile -- ^ drop and break at target tile, even if no hit | Durable -- ^ don't break even when 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 -- ^ can't throw or apply if not calm enough; -- AI and UI flag: don't risk identifying by use | Tactic !Tactic -- ^ overrides actor's tactic (TODO) deriving (Show, Eq, Ord, Generic) data EqpSlot = EqpSlotPeriodic | EqpSlotTimeout | EqpSlotAddHurtMelee | EqpSlotAddArmorMelee | EqpSlotAddHurtRanged | EqpSlotAddArmorRanged | EqpSlotAddMaxHP | EqpSlotAddMaxCalm | EqpSlotAddSpeed | EqpSlotAddSkills Ability.Ability | EqpSlotAddSight | EqpSlotAddSmell | EqpSlotAddLight | EqpSlotWeapon -- ^ a hack exclusively for AI that shares weapons deriving (Show, Eq, Ord, Generic) instance Hashable Effect instance Hashable TimerDice instance Hashable a => Hashable (Aspect a) instance Hashable ThrowMod instance Hashable Feature instance Hashable EqpSlot instance Binary Effect instance Binary TimerDice instance Binary a => Binary (Aspect a) instance Binary ThrowMod instance Binary Feature instance Binary EqpSlot slotName :: EqpSlot -> Text slotName EqpSlotPeriodic = "periodicity" slotName EqpSlotTimeout = "timeout" slotName EqpSlotAddHurtMelee = "to melee damage" slotName EqpSlotAddArmorMelee = "melee armor" slotName EqpSlotAddHurtRanged = "to ranged damage" slotName EqpSlotAddArmorRanged = "ranged armor" slotName EqpSlotAddMaxHP = "max HP" slotName EqpSlotAddMaxCalm = "max Calm" slotName EqpSlotAddSpeed = "speed" slotName EqpSlotAddSkills{} = "skills" slotName EqpSlotAddSight = "sight radius" slotName EqpSlotAddSmell = "smell radius" slotName EqpSlotAddLight = "light radius" slotName EqpSlotWeapon = "weapon damage" toVelocity :: Int -> Feature toVelocity n = ToThrow $ ThrowMod n 100 toLinger :: Int -> Feature toLinger n = ToThrow $ ThrowMod 100 n toOrganGameTurn :: GroupName ItemKind -> Dice.Dice -> Effect toOrganGameTurn grp nDm = CreateItem COrgan grp (TimerGameTurn nDm) toOrganActorTurn :: GroupName ItemKind -> Dice.Dice -> Effect toOrganActorTurn grp nDm = CreateItem COrgan grp (TimerActorTurn nDm) toOrganNone :: GroupName ItemKind -> Effect toOrganNone grp = CreateItem COrgan grp TimerNone -- | Catch invalid item kind definitions. validateSingleItemKind :: ItemKind -> [Text] validateSingleItemKind ItemKind{..} = [ "iname longer than 23" | T.length iname > 23 ] ++ validateRarity irarity -- Reject duplicate Timeout and Periodic. Otherwise the behaviour -- may not agree with the item's in-game description. ++ let periodicAspect :: Aspect a -> Bool periodicAspect Periodic = True periodicAspect _ = False ps = filter periodicAspect iaspects in ["more than one Periodic specification" | length ps > 1] ++ let timeoutAspect :: Aspect a -> Bool timeoutAspect Timeout{} = True timeoutAspect _ = False ts = filter timeoutAspect iaspects in ["more than one Timeout specification" | length ts > 1] -- TODO: if "treasure" stays wired-in, assure there are some treasure items -- TODO: (spans multiple contents) check that there is at least one item -- in each ifreq group for each level (thought more precisely we'd need -- to lookup caves and modes and only check at the levels the caves -- can appear at). -- | Validate all item kinds. validateAllItemKind :: [ItemKind] -> [Text] validateAllItemKind content = let kindFreq :: S.Set (GroupName ItemKind) -- cf. Kind.kindFreq kindFreq = let tuples = [ cgroup | k <- content , (cgroup, n) <- ifreq k , n > 0 ] in S.fromList tuples missingGroups = [ cgroup | k <- content , (cgroup, _) <- ikit k , S.notMember cgroup kindFreq ] errorMsg = case missingGroups of [] -> [] _ -> ["no groups" <+> tshow missingGroups <+> "among content that has groups" <+> tshow (S.elems kindFreq)] in errorMsg LambdaHack-0.5.0.0/Game/LambdaHack/Content/ModeKind.hs0000644000000000000000000001646412555256425020315 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} -- | The type of kinds of game modes. module Game.LambdaHack.Content.ModeKind ( Caves, Roster(..), Player(..), ModeKind(..), LeaderMode(..), AutoLeader(..) , Outcome(..), HiIndeterminant(..), HiCondPoly, HiSummand, HiPolynomial , validateSingleModeKind, validateAllModeKind ) where import Data.Binary import qualified Data.EnumMap.Strict as EM import qualified Data.IntMap.Strict as IM import Data.Text (Text) import qualified Data.Text as T import GHC.Generics (Generic) import qualified NLP.Miniutter.English as MU () import Game.LambdaHack.Common.Ability import qualified Game.LambdaHack.Common.Dice as Dice import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.Msg import Game.LambdaHack.Content.CaveKind import Game.LambdaHack.Content.ItemKind (ItemKind) -- | Game mode specification. data ModeKind = ModeKind { msymbol :: !Char -- ^ a symbol (matches the keypress, if any) , mname :: !Text -- ^ short description , mfreq :: !(Freqs ModeKind) -- ^ frequency within groups , mroster :: !Roster -- ^ players taking part in the game , mcaves :: !Caves -- ^ arena of the game , mdesc :: !Text -- ^ description } deriving Show -- | Requested cave groups for particular levels. The second component -- is the @Escape@ feature on the level. @True@ means it's represented -- by @<@, @False@, by @>@. type Caves = IM.IntMap (GroupName CaveKind, Maybe Bool) -- | The specification of players for the game mode. data Roster = Roster { rosterList :: ![Player Dice.Dice] -- ^ players in the particular team , rosterEnemy :: ![(Text, Text)] -- ^ the initial enmity matrix , rosterAlly :: ![(Text, Text)] -- ^ the initial aliance matrix } deriving (Show, Eq) -- | 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, Bounded, Generic) instance Binary Outcome data HiIndeterminant = HiConst | HiLoot | HiBlitz | HiSurvival | HiKill | HiLoss deriving (Show, Eq, Ord, Generic) instance Binary HiIndeterminant type HiPolynomial = [(HiIndeterminant, Double)] type HiSummand = (HiPolynomial, [Outcome]) -- | Conditional polynomial representing score calculation for this player. type HiCondPoly = [HiSummand] -- | Properties of a particular player. data Player a = Player { fname :: !Text -- ^ name of the player , fgroup :: !(GroupName ItemKind) -- ^ name of the monster group to control , fskillsOther :: !Skills -- ^ fixed skill modifiers to the non-leader -- actors; also summed with skills implied -- by ftactic (which is not fixed) , fcanEscape :: !Bool -- ^ the player can escape the dungeon , fneverEmpty :: !Bool -- ^ the faction declared killed if no actors , fhiCondPoly :: !HiCondPoly -- ^ score polynomial for the player , fhasNumbers :: !Bool -- ^ whether actors have numbers, not symbols , fhasGender :: !Bool -- ^ whether actors have gender , ftactic :: !Tactic -- ^ non-leader behave according to this -- tactic; can be changed during the game , fentryLevel :: !a -- ^ level where the initial members start , finitialActors :: !a -- ^ number of initial members , fleaderMode :: !LeaderMode -- ^ the mode of switching the leader , fhasUI :: !Bool -- ^ does the faction have a UI client -- (for control or passive observation) } deriving (Show, Eq, Ord, Generic) instance Binary a => Binary (Player a) -- | If a faction with @LeaderUI@ and @LeaderAI@ has any actor, it has a leader. data LeaderMode = LeaderNull -- ^ faction can have no leader, is whole under AI control | LeaderAI AutoLeader -- ^ leader under AI control | LeaderUI AutoLeader -- ^ leader under UI control, assumes @fhasUI@ deriving (Show, Eq, Ord, Generic) instance Binary LeaderMode data AutoLeader = AutoLeader { autoDungeon :: !Bool -- ^ leader switching between levels is automatically done by the server -- and client is not permitted to change to leaders from other levels -- (the frequency of leader level switching done by the server -- is controlled by @RuleKind.rleadLevelClips@); -- if the flag is @False@, server still does a subset -- of the automatic switching, e.g., when the old leader dies -- and no other actor of the faction resides on his level, -- but the client (particularly UI) is expected to do changes as well , autoLevel :: !Bool -- ^ leader switching within a level is automatically done by the server -- and client is not permitted to change leaders -- (server is guaranteed to switch leader within a level very rarely, -- e.g., when the old leader dies); -- if the flag is @False@, server still does a subset -- of the automatic switching, but the client is permitted to do more } deriving (Show, Eq, Ord, Generic) instance Binary AutoLeader -- TODO: (spans multiple contents) Check that caves with the given groups exist. -- | Catch invalid game mode kind definitions. validateSingleModeKind :: ModeKind -> [Text] validateSingleModeKind ModeKind{..} = [ "mname longer than 20" | T.length mname > 20 ] ++ validateSingleRoster mcaves mroster -- TODO: if the diplomacy system stays in, check no teams are at once -- in war and alliance, taking into account symmetry (but not transitvity) -- | Checks, in particular, that there is at least one faction with fneverEmpty -- or the game could get stuck when the dungeon is devoid of actors validateSingleRoster :: Caves -> Roster -> [Text] validateSingleRoster caves Roster{..} = [ "no player keeps the dungeon alive" | all (not . fneverEmpty) rosterList ] ++ concatMap (validateSinglePlayer caves) rosterList ++ let checkPl field pl = [ pl <+> "is not a player name in" <+> field | all ((/= pl) . fname) rosterList ] checkDipl field (pl1, pl2) = [ "self-diplomacy in" <+> field | pl1 == pl2 ] ++ checkPl field pl1 ++ checkPl field pl2 in concatMap (checkDipl "rosterEnemy") rosterEnemy ++ concatMap (checkDipl "rosterAlly") rosterAlly validateSinglePlayer :: Caves -> Player Dice.Dice -> [Text] validateSinglePlayer caves Player{..} = [ "fname empty:" <+> fname | T.null fname ] ++ [ "first word of fname longer than 15:" <+> fname | T.length (head $ T.words fname) > 15 ] ++ [ "no UI client, but UI leader:" <+> fname | not fhasUI && case fleaderMode of LeaderUI _ -> True _ -> False ] ++ [ "fentryLevel value not among cave numbers:" <+> fname | any (`notElem` IM.keys caves) [Dice.minDice fentryLevel .. Dice.maxDice fentryLevel] ] -- simplification ++ [ "fskillsOther not negative:" <+> fname | any (>= 0) $ EM.elems fskillsOther ] -- | Validate all game mode kinds. Currently always valid. validateAllModeKind :: [ModeKind] -> [Text] validateAllModeKind _ = [] LambdaHack-0.5.0.0/Game/LambdaHack/Content/CaveKind.hs0000644000000000000000000001112712555256425020276 0ustar0000000000000000-- | The type of cave layout kinds. module Game.LambdaHack.Content.CaveKind ( CaveKind(..), validateSingleCaveKind, validateAllCaveKind ) 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 import Game.LambdaHack.Content.ItemKind (ItemKind) import Game.LambdaHack.Content.PlaceKind import Game.LambdaHack.Content.TileKind (TileKind) -- | Parameters for the generation of dungeon levels. -- Warning: for efficiency, avoid embedded items in any of the common tiles. data CaveKind = CaveKind { csymbol :: !Char -- ^ a symbol , cname :: !Text -- ^ short description , cfreq :: !(Freqs CaveKind) -- ^ 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 , cactorCoeff :: !Int -- ^ the lower, the more monsters spawn , cactorFreq :: !(Freqs ItemKind) -- ^ actor groups to consider , citemNum :: !Dice.Dice -- ^ the number of items in the cave , citemFreq :: !(Freqs ItemKind) -- ^ item groups to consider , cplaceFreq :: !(Freqs PlaceKind) -- ^ place groups to consider , cpassable :: !Bool -- ^ are passable default tiles permitted , cdefTile :: !(GroupName TileKind) -- ^ the default cave tile , cdarkCorTile :: !(GroupName TileKind) -- ^ the dark cave corridor tile , clitCorTile :: !(GroupName TileKind) -- ^ the lit cave corridor tile , cfillerTile :: !(GroupName TileKind) -- ^ the filler wall , couterFenceTile :: !(GroupName TileKind) -- ^ the outer fence wall , clegendDarkTile :: !(GroupName TileKind) -- ^ the dark place plan legend , clegendLitTile :: !(GroupName TileKind) -- ^ the lit place plan legend } deriving Show -- No Eq and Ord to make extending it logically sound -- | 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. validateSingleCaveKind :: CaveKind -> [Text] validateSingleCaveKind 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 [ "cname longer than 25" | T.length cname > 25 ] ++ [ "cxsize < 7" | cxsize < 7 ] ++ [ "cysize < 7" | cysize < 7 ] ++ [ "minMinSizeX < 1" | minMinSizeX < 1 ] ++ [ "minMinSizeY < 1" | minMinSizeY < 1 ] ++ [ "minMaxSizeX < maxMinSizeX" | minMaxSizeX < maxMinSizeX ] ++ [ "minMaxSizeY < maxMinSizeY" | minMaxSizeY < maxMinSizeY ] ++ [ "cxsize too small" | maxGridX * (maxMinSizeX + 1) + xborder >= cxsize ] ++ [ "cysize too small" | maxGridY * (maxMinSizeY + 1) + yborder >= cysize ] -- | 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. validateAllCaveKind :: [CaveKind] -> [Text] validateAllCaveKind lk = if any (maybe False (> 0) . lookup "campaign random" . cfreq) lk then [] else ["no cave defined for \"campaign random\""] LambdaHack-0.5.0.0/Game/LambdaHack/Content/RuleKind.hs0000644000000000000000000000741312555256425020332 0ustar0000000000000000-- | The type of game rule sets and assorted game data. module Game.LambdaHack.Content.RuleKind ( RuleKind(..), FovMode(..), validateSingleRuleKind, validateAllRuleKind ) 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 holds 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 RuleKind) -- ^ frequency within groups , raccessible :: !(Maybe (Point -> Point -> Bool)) -- ^ see above , raccessibleDoor :: !(Maybe (Point -> Point -> Bool)) -- ^ see above , 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 , rwriteSaveClips :: !Int -- ^ game is saved that often , rleadLevelClips :: !Int -- ^ server switches leader level that often , rscoresFile :: !FilePath -- ^ name of the scores file , rsavePrefix :: !String -- ^ name of the savefile prefix , rnearby :: !Int -- ^ what distance between actors is 'nearby' } -- | Field Of View scanning mode. data FovMode = Shadow -- ^ restrictive shadow casting (not symmetric!) | 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." -- | Catch invalid rule kind definitions. -- In particular, this validates the ASCII art format (TODO). validateSingleRuleKind :: RuleKind -> [Text] validateSingleRuleKind _ = [] -- | Since we have only one rule kind, the set of rule kinds is always valid. validateAllRuleKind :: [RuleKind] -> [Text] validateAllRuleKind _ = [] 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)" LambdaHack-0.5.0.0/Game/LambdaHack/Content/PlaceKind.hs0000644000000000000000000000542212555256425020445 0ustar0000000000000000-- | The type of kinds of rooms, halls and passages. module Game.LambdaHack.Content.PlaceKind ( PlaceKind(..), Cover(..), Fence(..) , validateSinglePlaceKind, validateAllPlaceKind ) where import Data.Text (Text) import qualified Data.Text as T import Game.LambdaHack.Common.Misc import Game.LambdaHack.Content.TileKind (TileKind) -- | Parameters for the generation of small areas within a dungeon level. data PlaceKind = PlaceKind { psymbol :: !Char -- ^ a symbol , pname :: !Text -- ^ short description , pfreq :: !(Freqs PlaceKind) -- ^ frequency within groups , prarity :: !Rarity -- ^ rarity on given depths , pcover :: !Cover -- ^ how to fill whole place based on the corner , pfence :: !Fence -- ^ whether to fence place with solid border , ptopLeft :: ![Text] -- ^ plan of the top-left corner of the place , poverride :: ![(Char, GroupName TileKind)] -- ^ legend override } deriving Show -- No Eq and Ord to make extending it logically sound -- | 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 space, like the rooms floor | FGround -- ^ leave an empty space, like the caves ground | 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: (spans multiple contents) Check that all symbols in place plans -- are present in the legend. -- | Catch invalid place kind definitions. In particular, verify that -- the top-left corner map is rectangular and not empty. validateSinglePlaceKind :: PlaceKind -> [Text] validateSinglePlaceKind PlaceKind{..} = let dxcorner = case ptopLeft of [] -> 0 l : _ -> T.length l in [ "top-left corner empty" | dxcorner == 0 ] ++ [ "top-left corner not rectangular" | any (/= dxcorner) (map T.length ptopLeft) ] ++ validateRarity prarity -- | Validate all place kinds. Currently always valid. validateAllPlaceKind :: [PlaceKind] -> [Text] validateAllPlaceKind _ = [] LambdaHack-0.5.0.0/Game/LambdaHack/Content/TileKind.hs0000644000000000000000000001377712555256425020332 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} -- | The type of kinds of terrain tiles. module Game.LambdaHack.Content.TileKind ( TileKind(..), Feature(..) , validateSingleTileKind, validateAllTileKind, actionFeatures ) where import Control.DeepSeq import Control.Exception.Assert.Sugar import Data.Binary import Data.Hashable import qualified Data.IntSet as IS import qualified Data.Map.Strict as M import Data.Maybe import Data.Text (Text) import GHC.Generics (Generic) import Game.LambdaHack.Common.Color import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.Msg import Game.LambdaHack.Content.ItemKind (ItemKind) import qualified Game.LambdaHack.Content.ItemKind as IK -- | 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. 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 , tfeature :: ![Feature] -- ^ properties } deriving Show -- No Eq and Ord to make extending it logically sound -- | All possible terrain tile features. data Feature = Embed !(GroupName ItemKind) -- ^ embed an item of this group, to cause effects (WIP) | Cause !IK.Effect -- ^ causes the effect when triggered; -- more succint than @Embed@, but will -- probably get supplanted by @Embed@ | OpenTo !(GroupName TileKind) -- ^ goes from a closed to an open tile when altered | CloseTo !(GroupName TileKind) -- ^ goes from an open to a closed tile when altered | ChangeTo !(GroupName TileKind) -- ^ alters tile, but does not change walkability | HideAs !(GroupName TileKind) -- ^ when hidden, looks as a tile of the group | RevealAs !(GroupName TileKind) -- ^ 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) | 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 instance NFData Feature -- TODO: (spans multiple contents) check that all posible solid place -- fences have hidden counterparts. -- | Validate a single tile kind. validateSingleTileKind :: TileKind -> [Text] validateSingleTileKind TileKind{..} = [ "suspect tile is walkable" | Walkable `elem` tfeature && Suspect `elem` tfeature ] -- TODO: verify that OpenTo, CloseTo and ChangeTo are assigned as specified. -- | Validate all tile kinds. -- -- 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. validateAllTileKind :: [TileKind] -> [Text] validateAllTileKind lt = let listVis f = map (\kt -> ( ( tsymbol kt , 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 [] -> [] cfs -> ["tile confusions detected:" <+> tshow cfs] -- | 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 Embed{} -> Just feat Cause{} -> Just feat OpenTo{} -> Just $ OpenTo "" -- if needed, remove prefix/suffix CloseTo{} -> Just $ CloseTo "" ChangeTo{} -> Just $ ChangeTo "" Walkable -> Just feat Clear -> Just feat Suspect -> if markSuspect then Just feat else Nothing Impenetrable -> Just feat Trail -> Just feat -- doesn't affect tile behaviour, but important HideAs{} -> Nothing RevealAs{} -> Nothing Dark -> Nothing -- not important any longer, after FOV computed OftenItem -> Nothing OftenActor -> Nothing NoItem -> Nothing NoActor -> Nothing in IS.fromList $ map hash $ mapMaybe f $ tfeature t LambdaHack-0.5.0.0/Game/LambdaHack/SampleImplementation/0000755000000000000000000000000012555256425020771 5ustar0000000000000000LambdaHack-0.5.0.0/Game/LambdaHack/SampleImplementation/SampleMonadClient.hs0000644000000000000000000001030412555256425024662 0ustar0000000000000000{-# LANGUAGE CPP, 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 #ifdef EXPOSE_INTERNAL -- * Internal operations , CliImplementation #endif ) 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 } -- | Client 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 -- | The game-state semantics of atomic commands -- as computed on the client. 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 LambdaHack-0.5.0.0/Game/LambdaHack/SampleImplementation/SampleMonadServer.hs0000644000000000000000000001145112555256425024716 0ustar0000000000000000{-# LANGUAGE CPP, 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 #ifdef EXPOSE_INTERNAL -- * Internal operations , SerImplementation #endif ) where import Control.Applicative import Control.Concurrent 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 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.Common.Thread 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 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 = do let saveFile (_, ser) = fromMaybe "save" (ssavePrefixSer (sdebugSer ser)) <.> saveName exe serToSave = evalStateT (runSerImplementation m) SerState { serState = emptyState , serServer = emptyStateServer , serDict = EM.empty , serToSave } exeWithSaves = Save.wrapInSaves saveFile exe -- 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. -- TODO: send them a message to tell users "server crashed" -- and then wait for them to exit normally. Ex.handle (\(ex :: Ex.SomeException) -> do threadDelay 1000000 -- let clients report their errors Ex.throw ex) -- crash eventually, which kills clients exeWithSaves waitForChildren childrenServer -- no crash, wait for clients indefinitely LambdaHack-0.5.0.0/Game/LambdaHack/Atomic/0000755000000000000000000000000012555256425016056 5ustar0000000000000000LambdaHack-0.5.0.0/Game/LambdaHack/Atomic/MonadStateWrite.hs0000644000000000000000000001717112555256425021473 0ustar0000000000000000-- | 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 items embedded in a tile on the level. updateEmbed :: (ItemFloor -> ItemFloor) -> Level -> Level updateEmbed f lvl = lvl {lembed = f (lembed 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 -> 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 -> insertItemBody iid kit aid CEqp -> insertItemEqp iid kit aid CInv -> insertItemInv iid kit aid CSha -> do b <- getsState $ getActorBody aid insertItemSha iid kit (bfid b) insertItemBody :: MonadStateWrite m => ItemId -> ItemQuant -> ActorId -> m () insertItemBody iid kit aid = do let bag = EM.singleton iid kit upd = EM.unionWith mergeItemQuant bag updateActor aid $ \b -> b {borgan = upd (borgan b)} insertItemEqp :: MonadStateWrite m => ItemId -> ItemQuant -> ActorId -> m () insertItemEqp iid kit aid = do let bag = EM.singleton iid kit upd = EM.unionWith mergeItemQuant bag updateActor aid $ \b -> b {beqp = upd (beqp b)} insertItemInv :: MonadStateWrite m => ItemId -> ItemQuant -> ActorId -> m () insertItemInv iid kit aid = do let bag = EM.singleton iid kit upd = EM.unionWith mergeItemQuant bag updateActor aid $ \b -> b {binv = upd (binv b)} insertItemSha :: MonadStateWrite m => ItemId -> ItemQuant -> FactionId -> m () insertItemSha iid kit fid = do let bag = EM.singleton iid kit upd = EM.unionWith mergeItemQuant bag updateFaction fid $ \fact -> fact {gsha = upd (gsha fact)} 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{} -> assert `failure` 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 = assert `failure` "item already removed" `twith` (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 = assert `failure` "item already removed" `twith` (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 -> deleteItemBody iid kit aid CEqp -> deleteItemEqp iid kit aid CInv -> deleteItemInv iid kit aid CSha -> do b <- getsState $ getActorBody aid deleteItemSha iid kit (bfid b) deleteItemBody :: MonadStateWrite m => ItemId -> ItemQuant -> ActorId -> m () deleteItemBody iid kit aid = updateActor aid $ \b -> b {borgan = rmFromBag kit iid (borgan b) } deleteItemEqp :: MonadStateWrite m => ItemId -> ItemQuant -> ActorId -> m () deleteItemEqp iid kit aid = updateActor aid $ \b -> b {beqp = rmFromBag kit iid (beqp b)} deleteItemInv :: MonadStateWrite m => ItemId -> ItemQuant -> ActorId -> m () deleteItemInv iid kit aid = updateActor aid $ \b -> b {binv = rmFromBag kit iid (binv b)} deleteItemSha :: MonadStateWrite m => ItemId -> ItemQuant -> FactionId -> m () deleteItemSha iid kit fid = updateFaction fid $ \fact -> fact {gsha = rmFromBag kit iid (gsha fact)} -- Removing the part of the kit from the front 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 = assert `failure` "rm from empty slot" `twith` (k, iid, bag) rfb (Just (n, it)) = case compare n k of LT -> assert `failure` "rm more than there is" `twith` (n, kit, iid, bag) EQ -> Nothing -- TODO: assert as below GT -> assert (rmIt == take k it `blame` (rmIt, take k it, n, kit, iid, bag)) $ Just (n - k, drop k it) in EM.alter rfb iid bag LambdaHack-0.5.0.0/Game/LambdaHack/Atomic/CmdAtomic.hs0000644000000000000000000002352612555256425020262 0ustar0000000000000000{-# 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 -- . module Game.LambdaHack.Atomic.CmdAtomic ( CmdAtomic(..), UpdAtomic(..), SfxAtomic(..), HitAtomic(..) , undoUpdAtomic, undoSfxAtomic, undoCmdAtomic ) where import Control.Applicative import Data.Binary import Data.Int (Int64) import GHC.Generics (Generic) import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ClientOptions 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.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 (ItemKind) import qualified Game.LambdaHack.Content.ItemKind as IK import Game.LambdaHack.Content.TileKind (TileKind) import qualified Game.LambdaHack.Content.TileKind as TK -- | Abstract syntax of atomic commands, that is, atomic game state -- transformations. data CmdAtomic = UpdAtomic !UpdAtomic -- ^ atomic updates | SfxAtomic !SfxAtomic -- ^ atomic special effects 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 them to players. data UpdAtomic = -- Create/destroy actors and items. UpdCreateActor !ActorId !Actor ![(ItemId, Item)] | UpdDestroyActor !ActorId !Actor ![(ItemId, Item)] | UpdCreateItem !ItemId !Item !ItemQuant !Container | UpdDestroyItem !ItemId !Item !ItemQuant !Container | UpdSpotActor !ActorId !Actor ![(ItemId, Item)] | UpdLoseActor !ActorId !Actor ![(ItemId, Item)] | UpdSpotItem !ItemId !Item !ItemQuant !Container | UpdLoseItem !ItemId !Item !ItemQuant !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 | UpdFidImpressedActor !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 Target)) !(Maybe (ActorId, Maybe Target)) | UpdDiplFaction !FactionId !FactionId !Diplomacy !Diplomacy | UpdTacticFaction !FactionId !Tactic !Tactic | 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. | UpdTimeItem !ItemId !Container !ItemTimer !ItemTimer | UpdAgeGame !(Delta Time) ![LevelId] | UpdDiscover !Container !ItemId !(Kind.Id ItemKind) !ItemSeed !AbsDepth | UpdCover !Container !ItemId !(Kind.Id ItemKind) !ItemSeed !AbsDepth | UpdDiscoverKind !Container !ItemId !(Kind.Id ItemKind) | UpdCoverKind !Container !ItemId !(Kind.Id ItemKind) | UpdDiscoverSeed !Container !ItemId !ItemSeed !AbsDepth | UpdCoverSeed !Container !ItemId !ItemSeed !AbsDepth | UpdPerception !LevelId !Perception !Perception | UpdRestart !FactionId !DiscoveryKind !FactionPers !State !Int !DebugModeCli | UpdRestartServer !State | UpdResume !FactionId !FactionPers | UpdResumeServer !State | UpdKillExit !FactionId | UpdWriteSave | UpdMsgAll !Msg | UpdRecordHistory !FactionId deriving (Show, Eq, Generic) instance Binary UpdAtomic -- | Abstract syntax of atomic special effects, that is, atomic commands -- that only display special effects and don't change the state. data SfxAtomic = SfxStrike !ActorId !ActorId !ItemId !CStore !HitAtomic | SfxRecoil !ActorId !ActorId !ItemId !CStore !HitAtomic | SfxProject !ActorId !ItemId !CStore | SfxCatch !ActorId !ItemId !CStore | SfxApply !ActorId !ItemId !CStore | SfxCheck !ActorId !ItemId !CStore | SfxTrigger !ActorId !Point !TK.Feature | SfxShun !ActorId !Point !TK.Feature | SfxEffect !FactionId !ActorId !IK.Effect | SfxMsgFid !FactionId !Msg | SfxMsgAll !Msg | SfxActorStart !ActorId deriving (Show, Eq, Generic) instance Binary SfxAtomic -- | Determine if a strike special effect should depict a block of an attack. 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) UpdFidImpressedActor aid fromFid toFid -> Just $ UpdFidImpressedActor 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 UpdTacticFaction fid toT fromT -> Just $ UpdTacticFaction 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 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 UpdTimeItem iid c fromIt toIt -> Just $ UpdTimeItem iid c toIt fromIt UpdAgeGame delta lids -> Just $ UpdAgeGame (timeDeltaReverse delta) lids UpdDiscover c iid ik seed ldepth -> Just $ UpdCover c iid ik seed ldepth UpdCover c iid ik seed ldepth -> Just $ UpdDiscover c iid ik seed ldepth UpdDiscoverKind c iid ik -> Just $ UpdCoverKind c iid ik UpdCoverKind c iid ik -> Just $ UpdDiscoverKind c iid ik UpdDiscoverSeed c iid seed ldepth -> Just $ UpdCoverSeed c iid seed ldepth UpdCoverSeed c iid seed ldepth -> Just $ UpdDiscoverSeed c iid seed ldepth 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 UpdMsgAll{} -> Nothing -- only generated by @cmdAtomicFilterCli@ UpdRecordHistory{} -> Just cmd undoSfxAtomic :: SfxAtomic -> SfxAtomic undoSfxAtomic cmd = case cmd of SfxStrike source target iid cstore b -> SfxRecoil source target iid cstore b SfxRecoil source target iid cstore b -> SfxStrike source target iid cstore b SfxProject aid iid cstore -> SfxCatch aid iid cstore SfxCatch aid iid cstore -> SfxProject aid iid cstore SfxApply aid iid cstore -> SfxCheck aid iid cstore SfxCheck aid iid cstore -> SfxApply aid iid cstore 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) = UpdAtomic <$> undoUpdAtomic cmd undoCmdAtomic (SfxAtomic sfx) = Just $ SfxAtomic $ undoSfxAtomic sfx LambdaHack-0.5.0.0/Game/LambdaHack/Atomic/PosAtomicRead.hs0000644000000000000000000003657612555256425021125 0ustar0000000000000000-- | Semantics of atomic commands shared by client and server. -- See -- . module Game.LambdaHack.Atomic.PosAtomicRead ( PosAtomic(..), posUpdAtomic, posSfxAtomic , resetsFovCmdAtomic, breakUpdAtomic, breakSfxAtomic, loudUpdAtomic , seenAtomicCli, seenAtomicSer, generalMoveItem, posProjBody ) 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 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 qualified Game.LambdaHack.Content.ItemKind as IK import Game.LambdaHack.Content.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 atomic commands to factions, -- based on the position of the command, etc. Note that the server -- sees and smells all positions. 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 atomic update takes place. -- -- The goal of the mechanics is to ensure the commands don't carry -- significantly more information than their corresponding state diffs would. -- In other words, the atomic commands involving the positions seen by a client -- should convey similar information as the client would get by directly -- observing the changes the commands enact on the visible portion of server -- game state. The client is then free to change its copy of game state -- accordingly or not --- it only partially reflects reality anyway. -- -- 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 _ -> return $! posProjBody body UpdDestroyActor _ body _ -> return $! posProjBody body UpdCreateItem _ _ _ c -> singleContainer c UpdDestroyItem _ _ _ c -> singleContainer c UpdSpotActor _ body _ -> return $! posProjBody body UpdLoseActor _ body _ -> return $! posProjBody body UpdSpotItem _ _ _ c -> singleContainer c UpdLoseItem _ _ _ c -> singleContainer c UpdMoveActor aid fromP toP -> do b <- getsState $ getActorBody aid -- Non-projectile actors are never totally isolated from envirnoment; -- they hear, feel air movement, etc. return $! if bproj b then PosSight (blid b) [fromP, toP] else PosFidAndSight [bfid b] (blid b) [fromP, toP] UpdWaitActor aid _ -> singleAid aid UpdDisplaceActor source target -> do sb <- getsState $ getActorBody source tb <- getsState $ getActorBody target let ps = [bpos sb, bpos tb] lid = assert (blid sb == blid tb) $ blid sb return $! if bproj sb && bproj tb then PosSight lid ps else if bproj sb then PosFidAndSight [bfid tb] lid ps else if bproj tb then PosFidAndSight [bfid sb] lid ps else PosFidAndSight [bfid sb, bfid tb] lid ps 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 UpdFidImpressedActor aid _ _ -> singleAid aid UpdTrajectory aid _ _ -> singleAid aid UpdColorActor aid _ _ -> singleAid aid UpdQuitFaction{} -> return PosAll UpdLeadFaction fid _ _ -> do fact <- getsState $ (EM.! fid) . sfactionD return $! if fleaderMode (gplayer fact) /= LeaderNull then PosFidAndSer Nothing fid else PosNone UpdDiplFaction{} -> return PosAll UpdTacticFaction fid _ _ -> return $! PosFidAndSer Nothing fid 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 UpdTimeItem _ c _ _ -> singleContainer c UpdAgeGame _ _ -> return PosAll UpdDiscover c _ _ _ _ -> singleContainer c UpdCover c _ _ _ _ -> singleContainer c UpdDiscoverKind c _ _ -> singleContainer c UpdCoverKind c _ _ -> singleContainer c UpdDiscoverSeed c _ _ _ -> singleContainer c UpdCoverSeed c _ _ _ -> singleContainer c UpdPerception{} -> return PosNone UpdRestart fid _ _ _ _ _ -> return $! PosFid fid UpdRestartServer _ -> return PosSer UpdResume fid _ -> return $! PosFid fid UpdResumeServer _ -> return PosSer UpdKillExit fid -> return $! PosFid fid UpdWriteSave -> 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 _ _ _ CSha _ -> -- shared stash is private return PosNone -- TODO: PosSerAndFidIfSight; but probably never used SfxStrike source target _ _ _ -> doubleAid source target SfxRecoil _ _ _ CSha _ -> -- shared stash is private return PosNone -- TODO: PosSerAndFidIfSight; but probably never used SfxRecoil source target _ _ _ -> doubleAid source target SfxProject aid _ cstore -> singleContainer $ CActor aid cstore SfxCatch aid _ cstore -> singleContainer $ CActor aid cstore SfxApply aid _ cstore -> singleContainer $ CActor aid cstore SfxCheck aid _ cstore -> singleContainer $ CActor aid cstore 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 :: Actor -> PosAtomic posProjBody body = 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] doubleAid :: MonadStateRead m => ActorId -> ActorId -> m PosAtomic doubleAid source target = do (slid, sp) <- posOfAid source (tlid, tp) <- posOfAid target return $! assert (slid == tlid) $ PosSight slid [sp, tp] singleContainer :: MonadStateRead m => Container -> m PosAtomic singleContainer (CFloor lid p) = return $! PosSight lid [p] singleContainer (CEmbed 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 -- We assume other factions don't see leaders and we know the actor's -- faction always sees the atomic command, so the leader doesn't -- need to be updated (or the actor is a projectile, hence not a leader). b <- getsState $ getActorBody aid ais <- getsState $ getCarriedAssocs b return [ UpdLoseActor aid b ais , UpdSpotActor aid b {bpos = toP, boldpos = Just $ bpos b} ais ] 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 = Just $ bpos sb} sais , UpdLoseActor target tb tais , UpdSpotActor target tb {bpos = bpos sb, boldpos = Just $ bpos tb} tais ] UpdMoveItem iid k aid cstore1 cstore2 | cstore1 == CSha -- CSha is private || cstore2 == CSha -> containerMoveItem iid k (CActor aid cstore1) (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 (IK.RefillCalm (-1)) | not $ bproj sb ] ++ [SfxEffect (bfid sb) target (IK.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 _ _ _ (CActor _ CGround) -> 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 -- | Given the client, it's perception and an atomic command, determine -- if the client notices the command. seenAtomicCli :: Bool -> FactionId -> Perception -> PosAtomic -> Bool seenAtomicCli knowEvents fid per posAtomic = case posAtomic of PosSight _ ps -> all (`ES.member` totalVisible per) ps || knowEvents PosFidAndSight fids _ ps -> fid `elem` fids || 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 -- | Generate the atomic updates that jointly perform a given item move. generalMoveItem :: MonadStateRead m => ItemId -> Int -> Container -> Container -> m [UpdAtomic] generalMoveItem iid k c1 c2 = case (c1, c2) of (CActor aid1 cstore1, CActor aid2 cstore2) | aid1 == aid2 -> return [UpdMoveItem iid k aid1 cstore1 cstore2] _ -> containerMoveItem iid k c1 c2 containerMoveItem :: MonadStateRead m => ItemId -> Int -> Container -> Container -> m [UpdAtomic] containerMoveItem iid k c1 c2 = do bag <- getsState $ getCBag c1 case iid `EM.lookup` bag of Nothing -> assert `failure` (iid, k, c1, c2) Just (_, it) -> do item <- getsState $ getItemBody iid return [ UpdLoseItem iid item (k, take k it) c1 , UpdSpotItem iid item (k, take k it) c2 ] LambdaHack-0.5.0.0/Game/LambdaHack/Atomic/MonadAtomic.hs0000644000000000000000000000266212555256425020613 0ustar0000000000000000-- | Atomic monads for handling atomic game state transformations. module Game.LambdaHack.Atomic.MonadAtomic ( MonadAtomic(..) , broadcastUpdAtomic, broadcastSfxAtomic ) where import Data.Key (mapWithKeyM_) import Game.LambdaHack.Atomic.CmdAtomic import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.MonadStateRead import Game.LambdaHack.Common.State -- | The monad for executing atomic game state transformations. class MonadStateRead m => MonadAtomic m where -- | Execute an arbitrary atomic game state transformation. execAtomic :: CmdAtomic -> m () -- | Execute an atomic command that really changes the state. execUpdAtomic :: UpdAtomic -> m () execUpdAtomic = execAtomic . UpdAtomic -- | Execute an atomic command that only displays special effects. execSfxAtomic :: SfxAtomic -> m () execSfxAtomic = execAtomic . SfxAtomic -- | Create and broadcast a set of atomic updates, one for each client. broadcastUpdAtomic :: MonadAtomic m => (FactionId -> UpdAtomic) -> m () broadcastUpdAtomic fcmd = do factionD <- getsState sfactionD mapWithKeyM_ (\fid _ -> execUpdAtomic $ fcmd fid) factionD -- | Create and broadcast a set of atomic special effects, one for each client. broadcastSfxAtomic :: MonadAtomic m => (FactionId -> SfxAtomic) -> m () broadcastSfxAtomic fcmd = do factionD <- getsState sfactionD mapWithKeyM_ (\fid _ -> execSfxAtomic $ fcmd fid) factionD LambdaHack-0.5.0.0/Game/LambdaHack/Atomic/HandleAtomicWrite.hs0000644000000000000000000005546712555256425021776 0ustar0000000000000000-- | Semantics of atomic commands shared by client and server. -- See -- . module Game.LambdaHack.Atomic.HandleAtomicWrite ( handleCmdAtomic ) where import Control.Applicative 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 (ItemKind) import Game.LambdaHack.Content.ModeKind import Game.LambdaHack.Content.TileKind (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 kit c -> updCreateItem iid item kit c UpdDestroyItem iid item kit c -> updDestroyItem iid item kit c UpdSpotActor aid body ais -> updCreateActor aid body ais UpdLoseActor aid body ais -> updDestroyActor aid body ais UpdSpotItem iid item kit c -> updCreateItem iid item kit c UpdLoseItem iid item kit c -> updDestroyItem iid item kit 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 UpdFidImpressedActor aid fromFid toFid -> updFidImpressedActor 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 UpdTacticFaction fid toT fromT -> updTacticFaction 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 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 UpdTimeItem iid c fromIt toIt -> updTimeItem iid c fromIt toIt 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)) (return ()) UpdRestart _ _ _ s _ _ -> updRestart s UpdRestartServer s -> updRestartServer s UpdResume{} -> return () UpdResumeServer s -> updResumeServer s UpdKillExit{} -> return () UpdWriteSave -> 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 (itemsMatch item1 item2 `blame` "inconsistent created actor items" `twith` (aid, body, iid, item1, item2)) item2 -- keep the first found level modifyState $ updateItemD $ EM.insertWith h iid item itemsMatch :: Item -> Item -> Bool itemsMatch item1 item2 = jkindIx item1 == jkindIx item2 -- && aspects and effects are the same, but too much writing; -- Note that nothing else needs to be the same, since items are merged -- and clients have different views on dungeon items than the server. -- | 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) = itemsMatch (itemD EM.! iid) item let !_A = assert (allB match ais `blame` "destroyed actor items not found" `twith` (aid, body, ais, itemD)) () -- 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 -> ItemQuant -> Container -> m () updCreateItem iid item kit@(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. -- If items equivalent, pick the one found on easier level. let f item1 item2 = assert (itemsMatch item1 item2) item2 -- keep the first found level modifyState $ updateItemD $ EM.insertWith f iid item insertItemContainer 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@, -- It's incredibly costly and not noticeable for the player. -- 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" `twith` (iid, item, itemD)) () deleteItemContainer iid kit c updMoveActor :: MonadStateWrite m => ActorId -> Point -> Point -> m () updMoveActor aid fromP toP = assert (fromP /= toP) $ do b <- getsState $ getActorBody aid let !_A = assert (fromP == bpos b `blame` "unexpected moved actor position" `twith` (aid, fromP, toP, bpos b, b)) () updateActor aid $ \body -> body {bpos = toP, boldpos = Just fromP} updWaitActor :: MonadStateWrite m => ActorId -> Bool -> m () updWaitActor aid toWait = do b <- getsState $ getActorBody aid let !_A = assert (toWait /= bwait b `blame` "unexpected waited actor time" `twith` (aid, toWait, bwait b, b)) () 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 = Just spos} updateActor target $ \b -> b {bpos = spos, boldpos = Just tpos} updMoveItem :: MonadStateWrite m => ItemId -> Int -> ActorId -> CStore -> CStore -> m () updMoveItem iid k aid c1 c2 = assert (k > 0 && c1 /= c2) $ do bag <- getsState $ getActorBag aid c1 case iid `EM.lookup` bag of Nothing -> assert `failure` (iid, k, aid, c1, c2) Just (_, it) -> do deleteItemActor iid (k, take k it) aid c1 insertItemActor iid (k, take k it) aid c2 -- This is equaivalent to (but much cheaper than) updDestroyActor -- followed by updCreateActor. updAgeActor :: MonadStateWrite m => ActorId -> Delta Time -> m () updAgeActor aid delta = assert (delta /= Delta timeZero) $ do body <- getsState $ getActorBody aid let newBody = body {btime = timeShift (btime body) delta} -- Remove actor from @sprio@ at old time. rmPrio Nothing = assert `failure` "actor already removed" `twith` (aid, body) rmPrio (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 -- Add actor to @sprio@ at new time. addPrio Nothing = Just [aid] addPrio (Just l) = assert (aid `notElem` l `blame` "actor already added" `twith` (aid, body, l)) $ Just $ aid : l updPrio = EM.alter addPrio (btime newBody) . EM.alter rmPrio (btime body) updateLevel (blid body) $ updatePrio updPrio -- Modify actor body in @sactorD@. modifyState $ updateActorD $ EM.adjust (const newBody) aid 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} } updFidImpressedActor :: MonadStateWrite m => ActorId -> FactionId -> FactionId -> m () updFidImpressedActor aid fromFid toFid = assert (fromFid /= toFid) $ updateActor aid $ \b -> assert (bfidImpressed b == fromFid `blame` (aid, fromFid, toFid, b)) $ b {bfidImpressed = toFid} 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" `twith` (aid, fromT, toT, body)) () 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 let !_A = assert (fromCol == bcolor body `blame` "unexpected actor color" `twith` (aid, fromCol, toCol, body)) () updateActor aid $ \b -> b {bcolor = toCol} updQuitFaction :: MonadStateWrite m => FactionId -> Maybe Actor -> Maybe Status -> Maybe Status -> m () updQuitFaction fid mbody fromSt toSt = do let !_A = assert (fromSt /= toSt `blame` (fid, mbody, fromSt, toSt)) () let !_A = assert (maybe True ((fid ==) . bfid) mbody) () fact <- getsState $ (EM.! fid) . sfactionD let !_A = assert (fromSt == gquit fact `blame` "unexpected actor quit status" `twith` (fid, fromSt, toSt, fact)) () let adj fa = fa {gquit = toSt} updateFaction fid adj -- The previous leader is assumed to be alive. updLeadFaction :: MonadStateWrite m => FactionId -> Maybe (ActorId, Maybe Target) -> Maybe (ActorId, Maybe Target) -> m () updLeadFaction fid source target = assert (source /= target) $ do fact <- getsState $ (EM.! fid) . sfactionD let !_A = assert (fleaderMode (gplayer fact) /= LeaderNull) () -- @PosNone@ ensures this mtb <- getsState $ \s -> flip getActorBody s . fst <$> 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" `twith` (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" `twith` (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) updAutoFaction :: MonadStateWrite m => FactionId -> Bool -> m () updAutoFaction fid st = updateFaction fid (\fact -> assert (isAIFact fact == not st) $ fact {gplayer = automatePlayer st (gplayer fact)}) updTacticFaction :: MonadStateWrite m => FactionId -> Tactic -> Tactic -> m () updTacticFaction fid toT fromT = do let adj fact = let player = gplayer fact in assert (ftactic player == fromT) $ fact {gplayer = player {ftactic = toT}} 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 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 (bfidOriginal 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 updTimeItem :: MonadStateWrite m => ItemId -> Container -> ItemTimer -> ItemTimer -> m () updTimeItem iid c fromIt toIt = assert (fromIt /= toIt) $ do bag <- getsState $ getCBag c case iid `EM.lookup` bag of Just (k, it) -> do let !_A = assert (fromIt == it `blame` (k, it, iid, c, fromIt, toIt)) () deleteItemContainer iid (k, fromIt) c insertItemContainer iid (k, toIt) c Nothing -> assert `failure` (bag, iid, c, fromIt, toIt) -- | 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 LambdaHack-0.5.0.0/Game/LambdaHack/Atomic/BroadcastAtomicWrite.hs0000644000000000000000000002010412555256425022461 0ustar0000000000000000-- | Sending atomic commands to clients and executing them on the server. -- See -- . 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 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) $ -- 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; -- with deep equality these assertions can be expensive; optimize. let !_A = assert (case ps of PosSight{} -> True PosFidAndSight{} -> True PosFidAndSer (Just _) _ -> True _ -> not resets `blame` (ps, resets)) () -- 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 (fhasUI $ gplayer $ factionD EM.! fid) $ doSendUpdateUI fid cmdUI sendAI = doSendUpdateAI 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 psRem <- mapM posUpdAtomic remember -- Verify that we remember only currently seen things. let !_A = assert (allB seenNew psRem) () -- Verify that we remember only new things. let !_A = assert (allB (not . seenOld) psRem) () 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. carriedAssocs b = getCarriedAssocs b s inPrio = concatMap (\p -> posToActors p lid s) inFov fActor (aid, b) = let ais = carriedAssocs b in UpdSpotActor aid b ais inActor = map fActor inPrio -- Items. pMaybe p = maybe Nothing (\x -> Just (p, x)) inContainer fc itemFloor = let inItem = mapMaybe (\p -> pMaybe p $ EM.lookup p itemFloor) inFov fItem p (iid, kit) = UpdSpotItem iid (getItemBody iid s) kit (fc lid p) fBag (p, bag) = map (fItem p) $ EM.assocs bag in concatMap fBag inItem inFloor = inContainer CFloor (lfloor lvl) inEmbed = inContainer CEmbed (lembed lvl) -- Tiles. inTileMap = map (\p -> (p, hideTile (scops s) 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 inFloor ++ inEmbed ++ inActor ++ atomicTile ++ atomicSmell LambdaHack-0.5.0.0/Game/LambdaHack/Common/0000755000000000000000000000000012555256425016072 5ustar0000000000000000LambdaHack-0.5.0.0/Game/LambdaHack/Common/Faction.hs0000644000000000000000000001507512555256425020021 0ustar0000000000000000{-# LANGUAGE CPP #-} -- | 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(..), Status(..) , Target(..) , isHorrorFact , noRunWithMulti, isAIFact, autoDungeonLevel, automatePlayer , isAtWar, isAllied , difficultyBound, difficultyDefault, difficultyCoeff, difficultyInverse #ifdef EXPOSE_INTERNAL -- * Internal operations , Dipl #endif ) where import Control.Monad 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.Common.Point import Game.LambdaHack.Common.Vector import Game.LambdaHack.Content.ItemKind (ItemKind) import Game.LambdaHack.Content.ModeKind -- | All factions in the game, indexed by faction identifier. type FactionDict = EM.EnumMap FactionId Faction data Faction = Faction { gname :: !Text -- ^ individual name , gcolor :: !Color.Color -- ^ color of actors or their frames , gplayer :: !(Player Int) -- ^ the player spec for this faction , gdipl :: !Dipl -- ^ diplomatic mode , gquit :: !(Maybe Status) -- ^ cause of game end/exit , gleader :: !(Maybe (ActorId, Maybe Target)) -- ^ the leader of the faction and his target , gsha :: !ItemBag -- ^ faction's shared inventory , gvictims :: !(EM.EnumMap (Kind.Id ItemKind) Int) -- ^ members killed } deriving (Show, Eq, Ord) -- | 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 -- | 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) -- | 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, Ord) -- | 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. -- Actors that can be summoned should have "horror" in their @ifreq@ set. isHorrorFact :: Faction -> Bool isHorrorFact fact = fgroup (gplayer fact) == "horror" -- 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 $ gplayer fact in EM.findWithDefault 0 Ability.AbMove skillsOther >= 0 || case fleaderMode (gplayer fact) of LeaderNull -> True LeaderAI AutoLeader{} -> True LeaderUI AutoLeader{..} -> autoDungeon || autoLevel isAIFact :: Faction -> Bool isAIFact fact = case fleaderMode (gplayer fact) of LeaderNull -> True LeaderAI _ -> True LeaderUI _ -> False autoDungeonLevel :: Faction -> (Bool, Bool) autoDungeonLevel fact = case fleaderMode (gplayer fact) of LeaderNull -> (False, False) LeaderAI AutoLeader{..} -> (autoDungeon, autoLevel) LeaderUI AutoLeader{..} -> (autoDungeon, autoLevel) automatePlayer :: Bool -> Player a -> Player a automatePlayer st pl = let autoLeader False Player{fleaderMode=LeaderAI auto} = LeaderUI auto autoLeader True Player{fleaderMode=LeaderUI auto} = LeaderAI auto autoLeader _ Player{fleaderMode} = fleaderMode in pl {fleaderMode = autoLeader st pl} -- | 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 -- The function is its own inverse. difficultyInverse :: Int -> Int difficultyInverse n = difficultyBound + 1 - n instance Binary Faction where put Faction{..} = do put gname put gcolor put gplayer put gdipl put gquit put gleader put gsha put gvictims get = do 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 Status where put Status{..} = do put stOutcome put stDepth put stNewGame get = do stOutcome <- get stDepth <- get stNewGame <- get return $! Status{..} 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)" LambdaHack-0.5.0.0/Game/LambdaHack/Common/Request.hs0000644000000000000000000002331612555256425020063 0ustar0000000000000000{-# LANGUAGE DataKinds, ExistentialQuantification, GADTs, KindSignatures, StandaloneDeriving #-} -- | Abstract syntax of server commands. -- See -- . module Game.LambdaHack.Common.Request ( RequestAI(..), RequestUI(..), RequestTimed(..), RequestAnyAbility(..) , ReqFailure(..), impossibleReqFailure, showReqFailure, anyToUI , permittedPrecious, permittedProject, permittedApply ) where import Data.Maybe import Data.Text (Text) import Game.LambdaHack.Atomic import Game.LambdaHack.Common.Ability import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.Item import Game.LambdaHack.Common.ItemStrongest import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.Msg import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.Time import Game.LambdaHack.Common.Vector import qualified Game.LambdaHack.Content.ItemKind as IK import Game.LambdaHack.Content.ModeKind import qualified Game.LambdaHack.Content.TileKind as TK -- 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 !(Maybe Target) !RequestAI | ReqAIPong deriving instance Show RequestAI -- | Client-server requests sent by UI clients. data RequestUI = forall a. ReqUITimed !(RequestTimed a) | ReqUILeader !ActorId !(Maybe Target) !RequestUI | ReqUIGameRestart !ActorId !(GroupName ModeKind) !Int ![(Int, (Text, Text))] | ReqUIGameExit !ActorId | ReqUIGameSave | ReqUITactic !Tactic | 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 TK.Feature) -> RequestTimed 'AbAlter ReqWait :: RequestTimed 'AbWait ReqMoveItems :: ![(ItemId, Int, CStore, CStore)] -> RequestTimed 'AbMoveItem ReqProject :: !Point -> !Int -> !ItemId -> !CStore -> RequestTimed 'AbProject ReqApply :: !ItemId -> !CStore -> RequestTimed 'AbApply ReqTrigger :: !(Maybe TK.Feature) -> RequestTimed 'AbTrigger deriving instance Show (RequestTimed a) data ReqFailure = MoveNothing | MeleeSelf | MeleeDistant | DisplaceDistant | DisplaceAccess | DisplaceProjectiles | DisplaceDying | DisplaceBraced | DisplaceImmobile | DisplaceSupported | AlterUnskilled | AlterDistant | AlterBlockActor | AlterBlockItem | AlterNothing | EqpOverfull | EqpStackFull | ApplyUnskilled | ApplyRead | ApplyOutOfReach | ApplyCharging | ItemNothing | ItemNotCalm | NotCalmPrecious | ProjectUnskilled | ProjectAimOnself | ProjectBlockTerrain | ProjectBlockActor | ProjectNotRanged | ProjectFragile | ProjectOutOfReach | TriggerNothing | NoChangeDunLeader | NoChangeLvlLeader impossibleReqFailure :: ReqFailure -> Bool impossibleReqFailure reqFailure = case reqFailure of MoveNothing -> True MeleeSelf -> True MeleeDistant -> True DisplaceDistant -> True DisplaceAccess -> True DisplaceProjectiles -> True DisplaceDying -> True DisplaceBraced -> True DisplaceImmobile -> False -- unidentified skill items DisplaceSupported -> True AlterUnskilled -> False -- unidentified skill items AlterDistant -> True AlterBlockActor -> True -- adjacent actor always visible AlterBlockItem -> True -- adjacent item always visible AlterNothing -> True EqpOverfull -> False -- REVERT ME on branches other than 0.5.0 EqpStackFull -> True ApplyUnskilled -> False -- unidentified skill items ApplyRead -> False -- unidentified skill items ApplyOutOfReach -> True ApplyCharging -> False -- if aspects unknown, charging unknown ItemNothing -> True ItemNotCalm -> False -- unidentified skill items NotCalmPrecious -> False -- unidentified skill items ProjectUnskilled -> False -- unidentified skill items ProjectAimOnself -> True ProjectBlockTerrain -> True -- adjacent terrain always visible ProjectBlockActor -> True -- adjacent actor always visible ProjectNotRanged -> False -- unidentified skill items ProjectFragile -> False -- unidentified skill items ProjectOutOfReach -> True TriggerNothing -> True -- terrain underneath always visibl NoChangeDunLeader -> True NoChangeLvlLeader -> True 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 displace a distant actor" DisplaceAccess -> "switching places without access" DisplaceProjectiles -> "trying to displace multiple projectiles" 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 supported foe" AlterUnskilled -> "unskilled actors cannot alter tiles" 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" EqpStackFull -> "cannot equip the whole item stack" ApplyUnskilled -> "unskilled actors cannot apply items" ApplyRead -> "activating this kind of items requires skill level 2" ApplyOutOfReach -> "cannot apply an item out of reach" ApplyCharging -> "cannot apply an item that is still charging" ItemNothing -> "wasting time on void item manipulation" ItemNotCalm -> "you are too alarmed to sort through the shared stash" NotCalmPrecious -> "you are too alarmed to handle such an exquisite item" ProjectUnskilled -> "unskilled actors cannot aim" ProjectAimOnself -> "cannot aim at oneself" ProjectBlockTerrain -> "aiming obstructed by terrain" ProjectBlockActor -> "aiming blocked by an actor" ProjectNotRanged -> "to fling a non-missile requires fling skill 2" ProjectFragile -> "to lob a fragile item requires fling skill 3" ProjectOutOfReach -> "cannot aim an item out of reach" TriggerNothing -> "wasting time on triggering nothing" NoChangeDunLeader -> "no manual level change for your team" NoChangeLvlLeader -> "no manual leader change for your team" -- The item should not be applied nor thrown because it's too delicate -- to operate when not calm or becuse it's too precious to identify by use. permittedPrecious :: Bool -> Bool -> ItemFull -> Either ReqFailure Bool permittedPrecious calm10 forced itemFull = let isPrecious = IK.Precious `elem` jfeature (itemBase itemFull) in if not calm10 && not forced && isPrecious then Left NotCalmPrecious else Right $ IK.Durable `elem` jfeature (itemBase itemFull) || case itemDisco itemFull of Just ItemDisco{itemAE=Just _} -> True _ -> not isPrecious permittedProject :: [Char] -> Bool -> Int -> ItemFull -> Actor -> [ItemFull] -> Either ReqFailure Bool permittedProject triggerSyms forced skill itemFull@ItemFull{itemBase} b activeItems = let calm10 = calmEnough10 b activeItems mhurtRanged = strengthFromEqpSlot IK.EqpSlotAddHurtRanged itemFull in if not forced && skill < 1 then Left ProjectUnskilled else if not forced && isNothing mhurtRanged && skill < 2 then Left ProjectNotRanged else if not forced && IK.Fragile `elem` jfeature itemBase && skill < 3 then Left ProjectFragile else let legal = permittedPrecious calm10 forced itemFull in case legal of Left{} -> legal Right False -> legal Right True -> Right $ let hasEffects = case itemDisco itemFull of Just ItemDisco{itemAE=Just ItemAspectEffect{jeffects=[]}} -> False Just ItemDisco{ itemAE=Nothing , itemKind=IK.ItemKind{IK.ieffects=[]} } -> False _ -> True permittedSlot = if ' ' `elem` triggerSyms then case strengthEqpSlot itemBase of Just (IK.EqpSlotAddLight, _) -> True Just _ -> False Nothing -> True else jsymbol itemBase `elem` triggerSyms in hasEffects && permittedSlot permittedApply :: [Char] -> Time -> Int -> ItemFull -> Actor -> [ItemFull] -> Either ReqFailure Bool permittedApply triggerSyms localTime skill itemFull@ItemFull{itemBase} b activeItems = let calm10 = calmEnough10 b activeItems in if skill < 1 then Left ApplyUnskilled else if jsymbol itemBase == '?' && skill < 2 then Left ApplyRead -- We assume if the item has a timeout, all or most of interesting effects -- are under Recharging, so no point activating if not recharged. else if not $ hasCharge localTime itemFull then Left ApplyCharging else let legal = permittedPrecious calm10 False itemFull in case legal of Left{} -> legal Right False -> legal Right True -> Right $ if ' ' `elem` triggerSyms then IK.Applicable `elem` jfeature itemBase else jsymbol itemBase `elem` triggerSyms LambdaHack-0.5.0.0/Game/LambdaHack/Common/Level.hs0000644000000000000000000002257312555256425017506 0ustar0000000000000000-- | 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, 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.ItemKind (ItemKind) import Game.LambdaHack.Content.RuleKind import Game.LambdaHack.Content.TileKind (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 , lembed :: !ItemFloor -- ^ items embedded in the tile , 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]) -- ^ positions 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 , lactorCoeff :: !Int -- ^ the lower, the more monsters spawn , lactorFreq :: !(Freqs ItemKind) -- ^ frequency of spawned actors; [] for clients , litemNum :: !Int -- ^ number of initial items, 0 for clients , litemFreq :: !(Freqs ItemKind) -- ^ frequency of initial items; [] for clients , lsecret :: !Int -- ^ secret tile seed , lhidden :: !Int -- ^ secret tile density , lescape :: ![Point] -- ^ positions of IK.Escape tiles } 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 {-# INLINE at #-} at Level{ltile} p = ltile PointArray.! p 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) = lhidden lvl /= 0 && (lsecret lvl `Bits.rotateR` x `Bits.xor` y + x) `mod` lhidden lvl == 0 hideTile :: Kind.COps -> Level -> Point -> Kind.Id TileKind hideTile Kind.COps{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 (assertSparseItems lembed) put ltile put lxsize put lysize put lsmell put ldesc put lstair put lseen put lclear put ltime put lactorCoeff put lactorFreq put litemNum put litemFreq put lsecret put lhidden put lescape get = do ldepth <- get lprio <- get lfloor <- get lembed <- get ltile <- get lxsize <- get lysize <- get lsmell <- get ldesc <- get lstair <- get lseen <- get lclear <- get ltime <- get lactorCoeff <- get lactorFreq <- get litemNum <- get litemFreq <- get lsecret <- get lhidden <- get lescape <- get return $! Level{..} LambdaHack-0.5.0.0/Game/LambdaHack/Common/ContentDef.hs0000644000000000000000000000242412555256425020461 0ustar0000000000000000-- | 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 a -- ^ frequency within groups , validateSingle :: a -> [Text] -- ^ validate a content item and list all offences , validateAll :: [a] -> [Text] -- ^ validate the whole defined content of this type and list all offences , content :: ![a] -- ^ all the defined content of this type } LambdaHack-0.5.0.0/Game/LambdaHack/Common/LQueue.hs0000644000000000000000000000375612555256425017641 0ustar0000000000000000-- | 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 LambdaHack-0.5.0.0/Game/LambdaHack/Common/Item.hs0000644000000000000000000001122212555256425017322 0ustar0000000000000000{-# 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, DiscoveryKind, ItemSeed, ItemAspectEffect(..), DiscoveryEffect , ItemFull(..), ItemDisco(..), itemNoDisco, itemNoAE -- * Inventory management types , ItemTimer, ItemQuant, 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 Data.Traversable (traverse) import GHC.Generics (Generic) import System.Random (mkStdGen) 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.Common.Time 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 DiscoveryKind = 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] -- ^ the effects when applied } 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 DiscoveryEffect = 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 , itemTimer :: !ItemTimer , itemDisco :: !(Maybe ItemDisco) } deriving Show itemNoDisco :: (Item, Int) -> ItemFull itemNoDisco (itemBase, itemK) = ItemFull {itemBase, itemK, itemTimer = [], 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 -- ^ map symbol , jname :: !Text -- ^ generic name , jflavour :: !Flavour -- ^ 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 rollA = mapM (traverse castD) (iaspects kind) jaspects = St.evalState rollA (mkStdGen itemSeed) jeffects = ieffects kind in ItemAspectEffect{..} type ItemTimer = [Time] type ItemQuant = (Int, ItemTimer) type ItemBag = EM.EnumMap ItemId ItemQuant -- | All items in the dungeon (including in actor inventories), -- indexed by item identifier. type ItemDict = EM.EnumMap ItemId Item -- | 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 meaningul properties can be derived from the two. -- Note that @jlid@ is not meaningful; it gets forgotten if items from -- different levels roll the same random properties and so are merged. type ItemKnown = (ItemKindIx, ItemAspectEffect) LambdaHack-0.5.0.0/Game/LambdaHack/Common/File.hs0000644000000000000000000000721012555256425017305 0ustar0000000000000000-- | 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 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. 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 copy over data files, if not already there. We catch exceptions -- in case many clients try to do the same thing at the same time. tryCopyDataFiles :: FilePath -> (FilePath -> IO FilePath) -> [(FilePath, FilePath)] -> IO () tryCopyDataFiles dataDir pathsDataFile files = let cpFile (fin, fout) = do mpathsDataIn <- do pathsDataIn1 <- pathsDataFile fin bIn1 <- doesFileExist pathsDataIn1 if bIn1 then return $ Just pathsDataIn1 else do currentDir <- getCurrentDirectory let pathsDataIn2 = currentDir fin bIn2 <- doesFileExist pathsDataIn2 if bIn2 then return $ Just pathsDataIn2 else return Nothing case mpathsDataIn of Nothing -> return () Just pathsDataIn -> do let pathsDataOut = dataDir fout bOut <- doesFileExist pathsDataOut unless bOut $ Ex.handle (\(_ :: Ex.IOException) -> return ()) (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 LambdaHack-0.5.0.0/Game/LambdaHack/Common/Thread.hs0000644000000000000000000000132512555256425017636 0ustar0000000000000000-- | 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 LambdaHack-0.5.0.0/Game/LambdaHack/Common/Msg.hs0000644000000000000000000002414412555256425017161 0ustar0000000000000000{-# 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, endMsg, yesnoMsg, truncateMsg , Report, emptyReport, nullReport, singletonReport, addMsg, prependMsg , splitReport, renderReport, findInReport, lastMsgOfReport , History, emptyHistory, lengthHistory , addReport, renderHistory, lastReportOfHistory , Overlay(overlay), emptyOverlay, truncateToOverlay, toOverlay , Slideshow(slideshow), splitOverlay, toSlideshow , encodeLine, encodeOverlay, ScreenLine, toScreenLine, splitText ) where import Control.Applicative 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 Data.Vector.Binary () import qualified Data.Vector.Generic as G import qualified Data.Vector.Unboxed as U import qualified NLP.Miniutter.English as MU import Game.LambdaHack.Common.Color import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.Point import qualified Game.LambdaHack.Common.RingBuffer as RB import Game.LambdaHack.Common.Time infixr 6 <+> -- TODO: not needed when we require a very new minimorph (<+>) :: Text -> Text -> Text (<+>) = (MU.<+>) -- Show and pack the result of @show@. tshow :: Show a => a -> Text tshow x = T.pack $ show 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 \"end of screenfuls of text\" mark. endMsg :: Msg endMsg = "--end-- " -- | 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 prependMsg :: Msg -> Report -> Report prependMsg m r | T.null m = r prependMsg y (Report xns) = Report $ xns ++ [(encodeUtf8 y, 1)] -- | 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 <> " 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. This is a ring buffer of the given length newtype History = History (RB.RingBuffer (Time, Report)) deriving (Show, Binary) -- | Empty history of reports of the given maximal length. emptyHistory :: Int -> History emptyHistory size = History $ RB.empty size (timeZero, Report []) -- | Add a report to history, handling repetitions. addReport :: History -> Time -> Report -> History addReport h _ (Report []) = h addReport !(History rb) !time !rep@(Report m) = case RB.uncons rb of Nothing -> History $ RB.cons (time, rep) rb Just ((oldTime, Report h), hRest) -> case (reverse m, h) of ((s1, n1) : rs, (s2, n2) : hhs) | s1 == s2 -> let hist = RB.cons (oldTime, Report ((s2, n1 + n2) : hhs)) hRest in History $ if null rs then hist else RB.cons (time, Report (reverse rs)) hist _ -> History $ RB.cons (time, rep) rb lengthHistory :: History -> Int lengthHistory (History rs) = RB.rbLength rs -- | Render history as many lines of text, wrapping if necessary. renderHistory :: History -> Overlay renderHistory (History rb) = let l = RB.toList rb (x, y) = normalLevelBound screenLength = y + 2 reportLines = concatMap (splitReportForHistory (x + 1)) l padding = screenLength - length reportLines `mod` screenLength in toOverlay $ replicate padding "" ++ reportLines splitReportForHistory :: X -> (Time, Report) -> [Text] splitReportForHistory w (time, r) = -- TODO: display time fractions with granularity enough to differ -- from previous and next report, if possible let turns = time `timeFitUp` timeTurn ts = splitText (w - 1) $ tshow turns <> ":" <+> renderReport r in case ts of [] -> [] hd : tl -> hd : map (T.cons ' ') tl lastReportOfHistory :: History -> Maybe Report lastReportOfHistory (History rb) = snd . fst <$> RB.uncons rb type ScreenLine = U.Vector Int32 toScreenLine :: Text -> ScreenLine toScreenLine t = let f = AttrChar defAttr 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 . 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 :: Maybe Bool -> Y -> Overlay -> Overlay -> Slideshow splitOverlay onBlank yspace (Overlay msg) (Overlay ls) = let len = length msg endB = [ toScreenLine $ endMsg <> "[press PGUP to see previous, ESC to cancel]" | onBlank == Just False ] 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 ++ endB] -- all fits on 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 first pair element is not @Nothing@, the overlay is displayed -- over a blank screen, including the bottom lines. The boolean flag -- then indicates whether to start at the topmost screenful or bottommost. newtype Slideshow = Slideshow {slideshow :: (Maybe Bool, [Overlay])} deriving (Show, Eq) instance Monoid Slideshow where mempty = Slideshow (Nothing, []) mappend (Slideshow (b1, l1)) (Slideshow (_, l2)) = Slideshow (b1, 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 :: Maybe Bool -> [[Text]] -> Slideshow toSlideshow onBlank l = Slideshow (onBlank, map toOverlay l) LambdaHack-0.5.0.0/Game/LambdaHack/Common/Kind.hs0000644000000000000000000001313712555256425017320 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving, RankNTypes, TypeFamilies #-} -- | General content types and operations. module Game.LambdaHack.Common.Kind ( Id, Speedup, Ops(..), COps(..), createOps, stdRuleset ) where import Control.Exception.Assert.Sugar 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 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.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. type family Speedup a -- | Content operations for the content of type @a@. data Ops a = Ops { okind :: Id a -> a -- ^ the content element at given id , ouniqGroup :: GroupName a -> Id a -- ^ the id of the unique member of -- a singleton content group , opick :: GroupName a -> (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. GroupName a -> (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, validateSingle, validateAll} = assert (length content <= fromEnum (maxBound :: Id a)) $ let kindMap :: EM.EnumMap (Id a) a !kindMap = EM.fromDistinctAscList $ zip [Id 0..] content kindFreq :: M.Map (GroupName a) [(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 = let assFail = assert `failure` "no kind" `twith` (i, kindMap) in EM.findWithDefault assFail i kindMap correct a = not (T.null (getName a)) && all ((> 0) . snd) (getFreq a) singleOffenders = [ (offences, a) | a <- content , let offences = validateSingle a , not (null offences) ] allOffences = validateAll content in assert (allB correct content) $ assert (null singleOffenders `blame` "some content items not valid" `twith` singleOffenders) $ assert (null allOffences `blame` "the content set not valid" `twith` (allOffences, content)) -- By this point 'content' can be GCd. Ops { okind , ouniqGroup = \cgroup -> let freq = let assFail = assert `failure` "no unique group" `twith` (cgroup, kindFreq) in M.findWithDefault assFail 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 ('" <> tshow 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 (uncurry f) 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 _ -> assert `failure` "no group '" <> tshow cgroup <> "' among content that has groups" <+> tshow (M.keys kindFreq) , 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 , 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 LambdaHack-0.5.0.0/Game/LambdaHack/Common/Point.hs0000644000000000000000000001226112555256425017521 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} -- | 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.DeepSeq import Control.Exception.Assert.Sugar import Data.Binary import Data.Bits (unsafeShiftL, unsafeShiftR, (.&.)) import Data.Int (Int32) import GHC.Generics (Generic) -- | 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 (Read, Eq, Ord, Generic) 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 instance NFData Point -- 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 && x <= maxLevelDim && y <= maxLevelDim `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 . 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 (Point x0) (fromTo1 y0 y1) | y0 == y1 = map (`Point` y0) (fromTo1 x0 x1) | otherwise = assert `failure` "diagonal fromTo" `twith` ((x0, y0), (x1, y1)) in result LambdaHack-0.5.0.0/Game/LambdaHack/Common/Response.hs0000644000000000000000000000117012555256425020223 0ustar0000000000000000-- | Abstract syntax of client commands. -- See -- . 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 LambdaHack-0.5.0.0/Game/LambdaHack/Common/State.hs0000644000000000000000000001512012555256425017505 0ustar0000000000000000-- | 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, sgameModeId -- * 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.ModeKind import Game.LambdaHack.Content.TileKind (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.ScoreDict -- ^ high score table , _sgameModeId :: !(Kind.Id ModeKind) -- ^ current game mode } deriving (Show, Eq) -- TODO: add a flag 'fresh' and when saving levels, don't save -- and when loading regenerate this level. unknownLevel :: Kind.COps -> AbsDepth -> X -> Y -> Text -> ([Point], [Point]) -> Int -> Int -> Int -> [Point] -> Level unknownLevel Kind.COps{cotile=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 , lembed = EM.empty , ltile = unknownTileMap unknownId outerId lxsize lysize , lxsize , lysize , lsmell = EM.empty , ldesc , lstair , lseen = 0 , lclear , ltime = timeZero , lactorCoeff = 0 , 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.ScoreDict -> Kind.Id ModeKind -> State defStateGlobal _sdungeon _stotalDepth _sfactionD _scops _shigh _sgameModeId = 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 , _sgameModeId = toEnum 0 -- the initial value is unused } -- 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). -- TODO: RNG should be secret, too, but we also want it to be deterministic, -- to aid in bug replication -- | Local state created by removing secret information from global -- state components. localFromGlobal :: State -> State localFromGlobal State{..} = State { _sdungeon = EM.map (\Level{..} -> unknownLevel _scops 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.ScoreDict shigh = _shigh sgameModeId :: State -> Kind.Id ModeKind sgameModeId = _sgameModeId instance Binary State where put State{..} = do put _sdungeon put _stotalDepth put _sactorD put _sitemD put _sfactionD put _stime put _shigh put _sgameModeId get = do _sdungeon <- get _stotalDepth <- get _sactorD <- get _sitemD <- get _sfactionD <- get _stime <- get _shigh <- get _sgameModeId <- get let _scops = undefined -- overwritten by recreated cops return $! State{..} LambdaHack-0.5.0.0/Game/LambdaHack/Common/Flavour.hs0000644000000000000000000001026712555256425020052 0ustar0000000000000000{-# 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, zipLiquid , -- * 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 data FancyName = Plain | Fancy | Liquid deriving (Show, Eq, Ord, Generic) instance Hashable FancyName instance Binary FancyName -- TODO: add more variety, as the number of items increases -- | 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 Hashable Flavour instance Binary Flavour -- | Turn a colour set into a flavour set. zipPlain, zipFancy, zipLiquid :: [Color] -> [Flavour] zipPlain = map (Flavour Plain) zipFancy = map (Flavour Fancy) zipLiquid = map (Flavour Liquid) -- | The standard full set of flavours. stdFlav :: [Flavour] stdFlav = zipPlain stdCol ++ zipFancy stdCol ++ zipLiquid 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=Plain, ..} = colorToPlainName baseColor flavourToName Flavour{fancyName=Fancy, ..} = colorToFancyName baseColor flavourToName Flavour{fancyName=Liquid, ..} = colorToLiquidName 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 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" -- | 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 BrBlack = "pitchy" colorToLiquidName BrRed = "red-speckled" colorToLiquidName BrGreen = "sappy" colorToLiquidName BrYellow = "gold" colorToLiquidName BrBlue = "blue-speckled" colorToLiquidName BrMagenta = "hazy" colorToLiquidName BrCyan = "misty" colorToLiquidName BrWhite = "shining" -- | 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 LambdaHack-0.5.0.0/Game/LambdaHack/Common/MonadStateRead.hs0000644000000000000000000000375412555256425021272 0ustar0000000000000000-- | 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, factionCanEscape , getGameMode, getEntryArena ) 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 qualified Game.LambdaHack.Common.Kind as Kind import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.State import Game.LambdaHack.Content.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 (fhasUI . gplayer) $ EM.elems factionD posOfAid :: MonadStateRead m => ActorId -> m (LevelId, Point) posOfAid aid = do b <- getsState $ getActorBody aid return (blid b, bpos b) factionCanEscape :: MonadStateRead m => FactionId -> m Bool factionCanEscape fid = do fact <- getsState $ (EM.! fid) . sfactionD dungeon <- getsState sdungeon let escape = any (not . null . lescape) $ EM.elems dungeon return $! escape && fcanEscape (gplayer fact) getGameMode :: MonadStateRead m => m ModeKind getGameMode = do Kind.COps{comode=Kind.Ops{okind}} <- getsState scops t <- getsState sgameModeId return $! okind t getEntryArena :: MonadStateRead m => Faction -> m LevelId getEntryArena fact = 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 $ fentryLevel $ gplayer fact LambdaHack-0.5.0.0/Game/LambdaHack/Common/Random.hs0000644000000000000000000000707412555256425017656 0ustar0000000000000000-- | 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 let !_A = assert (n >= 0 && n <= depth `blame` "invalid depth for dice rolls" `twith` (n, depth)) () dc <- frequency $ Dice.diceConst dice dl <- frequency $ Dice.diceLevel dice return $! (dc + (dl * max 0 (n - 1)) `div` max 1 (depth - 1)) * Dice.diceMult 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) LambdaHack-0.5.0.0/Game/LambdaHack/Common/Perception.hs0000644000000000000000000000621112555256425020536 0ustar0000000000000000{-# 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 } LambdaHack-0.5.0.0/Game/LambdaHack/Common/Save.hs0000644000000000000000000001046612555256425017333 0ustar0000000000000000-- | 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 copy 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 LambdaHack-0.5.0.0/Game/LambdaHack/Common/Color.hs0000644000000000000000000000742612555256425017515 0ustar0000000000000000{-# 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 LambdaHack-0.5.0.0/Game/LambdaHack/Common/HighScore.hs0000644000000000000000000002036412555256425020306 0ustar0000000000000000{-# LANGUAGE CPP, DeriveGeneric, GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | High score table operations. module Game.LambdaHack.Common.HighScore ( ScoreDict, ScoreTable , empty, register, showScore, getTable, getRecord, highSlideshow #ifdef EXPOSE_INTERNAL -- * Internal operations , ScoreRecord #endif ) 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 (ItemKind) import Game.LambdaHack.Content.ModeKind (HiCondPoly, HiIndeterminant (..), ModeKind, Outcome (..)) -- | 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 -- | The list of scores, in decreasing order. newtype ScoreTable = ScoreTable [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 (Kind.Id ModeKind) ScoreTable -- | 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 <+> gplayerName score <+> died <> "," <+> victims <> "," , " " <> diffText <> "after" <+> tturns <+> "on" <+> curDate <> "." ] getTable :: Kind.Id ModeKind -> ScoreDict -> ScoreTable getTable = EM.findWithDefault (ScoreTable []) getRecord :: Int -> ScoreTable -> ScoreRecord getRecord pos (ScoreTable table) = fromMaybe (assert `failure` (pos, table)) $ listToMaybe $ drop (pred pos) table -- | 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 -> 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 -> HiCondPoly -> (Bool, (ScoreTable, Int)) register table total time status@Status{stOutcome} date difficulty gplayerName ourVictims theirVictims hiCondPoly = let turnsSpent = fromIntegral $ timeFitUp time timeTurn hiInValue (hi, c) = case hi of HiConst -> c HiLoot -> c * fromIntegral total 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 * fromIntegral (sum (EM.elems theirVictims)) HiLoss -> c * fromIntegral (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 points = (ceiling :: Double -> Int) $ hiCondValue hiCondPoly * 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 -> Text -- ^ the name of the game mode -> Slideshow highSlideshow table pos gameModeName = let (_, nlines) = normalLevelBound -- TODO: query terminal size instead height = nlines `div` 3 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 -> -- 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 best" -- "greatest heroes" doesn't fit else "(bonus included)") Escape -> ("your dashing coup", MU.Sg3rd, if pos <= height then "among the best" else "(bonus included)") Restart -> ("your abortive attempt", MU.Sg3rd, "(no bonus)") subject = makePhrase [efforts, "in", MU.Capitalize $ MU.Text gameModeName] msg = makeSentence [ MU.SubjectVerb person MU.Yes (MU.Text subject) "award you" , MU.Ordinal pos, "place", msgUnless ] in toSlideshow Nothing $ map ([msg, "\n"] ++) $ showCloseScores pos table height LambdaHack-0.5.0.0/Game/LambdaHack/Common/Time.hs0000644000000000000000000001733212555256425017332 0ustar0000000000000000{-# LANGUAGE DeriveFunctor, GeneralizedNewtypeDeriving #-} -- | Game time and speed. module Game.LambdaHack.Common.Time ( Time, timeZero, timeClip, timeTurn, timeEpsilon , absoluteTimeAdd, absoluteTimeNegate, timeFit, timeFitUp , Delta(..), timeShift, timeDeltaToFrom , timeDeltaSubtract, timeDeltaReverse, timeDeltaScale , timeDeltaToDigit, ticksPerMeter , Speed, toSpeed, fromSpeed, speedZero, speedNormal , speedScale, timeDeltaDiv, 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) -- | Time time vector between the second and the first absolute times. -- The arguments are in the same order as in the underlying scalar subtraction. timeDeltaSubtract :: Delta Time -> Delta Time -> Delta Time timeDeltaSubtract (Delta (Time t1)) (Delta (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)) -- | Divide a time vector. timeDeltaDiv :: Delta Time -> Int -> Delta Time timeDeltaDiv (Delta (Time t)) n = Delta (Time (t `div` fromIntegral 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 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 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 toSpeed s = Speed $ fromIntegral s * sInMs `div` 10 -- Can't be lower or actors would slow down (via tmp organs and weight), -- boost time with InsertMove, speed up and have lots of free moves. minimalSpeed :: Int64 minimalSpeed = 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 minimalSpeed v -- | Calculate projectile speed from item weight in grams -- and velocity percent modifier. -- See . 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 = minimalSpeed -- 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 = 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 . -- 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 `divUp` 100 LambdaHack-0.5.0.0/Game/LambdaHack/Common/ItemDescription.hs0000644000000000000000000002154412555256425021536 0ustar0000000000000000-- | Descripitons of items. module Game.LambdaHack.Common.ItemDescription ( partItemN, partItem, partItemWs, partItemAW, partItemMediumAW, 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.Dice as Dice 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.Common.Time import qualified Game.LambdaHack.Content.ItemKind as IK -- | The part of speech describing the item parameterized by the number -- of effects/aspects to show.. partItemN :: Int -> Int -> CStore -> Time -> ItemFull -> (Bool, MU.Part, MU.Part) partItemN fullInfo n c localTime itemFull = let genericName = jname $ itemBase itemFull in case itemDisco itemFull of Nothing -> let flav = flavourToName $ jflavour $ itemBase itemFull in (False, MU.Text $ flav <+> genericName, "") Just iDisco -> let (toutN, it1) = case strengthFromEqpSlot IK.EqpSlotTimeout itemFull of Nothing -> (0, []) Just timeout -> let timeoutTurns = timeDeltaScale (Delta timeTurn) timeout charging startT = timeShift startT timeoutTurns > localTime in (timeout, filter charging (itemTimer itemFull)) len = length it1 chargingAdj | toutN == 0 = "temporary" | otherwise = "charging" timer | len == 0 = "" | itemK itemFull == 1 && len == 1 = "(" <> chargingAdj <> ")" | otherwise = "(" <> tshow len <+> chargingAdj <> ")" skipRecharging = fullInfo <= 4 && len >= itemK itemFull effTs = filter (not . T.null) $ textAllAE fullInfo skipRecharging c itemFull ts = take n effTs ++ ["(...)" | length effTs > n] ++ [timer] isUnique aspects = IK.Unique `elem` aspects unique = case iDisco of ItemDisco{itemAE=Just ItemAspectEffect{jaspects}} -> isUnique jaspects ItemDisco{itemKind} -> isUnique $ IK.iaspects itemKind capName = if unique then MU.Capitalize $ MU.Text genericName else MU.Text genericName in (unique, capName, MU.Phrase $ map MU.Text ts) -- | The part of speech describing the item. partItem :: CStore -> Time -> ItemFull -> (Bool, MU.Part, MU.Part) partItem = partItemN 5 4 textAllAE :: Int -> Bool -> CStore -> ItemFull -> [Text] textAllAE fullInfo skipRecharging cstore ItemFull{itemBase, itemDisco} = let features | fullInfo >= 9 = map featureToSuff $ sort $ jfeature itemBase | otherwise = [] in case itemDisco of Nothing -> features Just ItemDisco{itemKind, itemAE} -> let periodicAspect :: IK.Aspect a -> Bool periodicAspect IK.Periodic = True periodicAspect _ = False timeoutAspect :: IK.Aspect a -> Bool timeoutAspect IK.Timeout{} = True timeoutAspect _ = False noEffect :: IK.Effect -> Bool noEffect IK.NoEffect{} = True noEffect _ = False hurtEffect :: IK.Effect -> Bool hurtEffect (IK.Hurt _) = True hurtEffect (IK.Burn _) = True hurtEffect _ = False notDetail :: IK.Effect -> Bool notDetail IK.Explode{} = fullInfo >= 6 notDetail _ = True active = cstore `elem` [CEqp, COrgan] || cstore == CGround && isJust (strengthEqpSlot itemBase) splitAE :: (Num a, Show a, Ord a) => (a -> Text) -> [IK.Aspect a] -> (IK.Aspect a -> Text) -> [IK.Effect] -> (IK.Effect -> Text) -> [Text] splitAE reduce_a aspects ppA effects ppE = let mperiodic = find periodicAspect aspects mtimeout = find timeoutAspect aspects mnoEffect = find noEffect effects restAs = sort aspects (hurtEs, restEs) = partition hurtEffect $ sort $ filter notDetail effects aes = if active then map ppA restAs ++ map ppE restEs else map ppE restEs ++ map ppA restAs rechargingTs = T.intercalate (T.singleton ' ') $ filter (not . T.null) $ map ppE $ stripRecharging restEs onSmashTs = T.intercalate (T.singleton ' ') $ filter (not . T.null) $ map ppE $ stripOnSmash restEs durable = IK.Durable `elem` jfeature itemBase periodicOrTimeout = case mperiodic of _ | skipRecharging || T.null rechargingTs -> "" Just IK.Periodic -> case mtimeout of Just (IK.Timeout 0) | not durable -> "(each turn until gone:" <+> rechargingTs <> ")" Just (IK.Timeout t) -> "(every" <+> reduce_a t <> ":" <+> rechargingTs <> ")" _ -> "" _ -> case mtimeout of Just (IK.Timeout t) -> "(timeout" <+> reduce_a t <> ":" <+> rechargingTs <> ")" _ -> "" onSmash = if T.null onSmashTs then "" else "(on smash:" <+> onSmashTs <> ")" noEff = case mnoEffect of Just (IK.NoEffect t) -> [t] _ -> [] in noEff ++ if fullInfo >= 5 || fullInfo >= 2 && null noEff then [periodicOrTimeout] ++ map ppE hurtEs ++ aes ++ [onSmash | fullInfo >= 7] else map ppE hurtEs aets = case itemAE of Just ItemAspectEffect{jaspects, jeffects} -> splitAE tshow jaspects aspectToSuffix jeffects effectToSuffix Nothing -> splitAE (maybe "?" tshow . Dice.reduceDice) (IK.iaspects itemKind) kindAspectToSuffix (IK.ieffects itemKind) kindEffectToSuffix in aets ++ features -- TODO: use kit partItemWs :: Int -> CStore -> Time -> ItemFull -> MU.Part partItemWs count c localTime itemFull = let (unique, name, stats) = partItem c localTime itemFull in if unique && count == 1 then MU.Phrase ["the", name, stats] else MU.Phrase [MU.CarWs count name, stats] partItemAW :: CStore -> Time -> ItemFull -> MU.Part partItemAW c localTime itemFull = let (unique, name, stats) = partItemN 4 4 c localTime itemFull in if unique then MU.Phrase ["the", name, stats] else MU.AW $ MU.Phrase [name, stats] partItemMediumAW :: CStore -> Time -> ItemFull -> MU.Part partItemMediumAW c localTime itemFull = let (unique, name, stats) = partItemN 5 100 c localTime itemFull in if unique then MU.Phrase ["the", name, stats] else MU.AW $ MU.Phrase [name, stats] partItemWownW :: MU.Part -> CStore -> Time -> ItemFull -> MU.Part partItemWownW partA c localTime itemFull = let (_, name, stats) = partItemN 4 4 c localTime itemFull in MU.WownW partA $ MU.Phrase [name, stats] itemDesc :: CStore -> Time -> ItemFull -> Overlay itemDesc c localTime itemFull = let (_, name, stats) = partItemN 10 100 c localTime itemFull nstats = makePhrase [name, stats] desc = case itemDisco itemFull of Nothing -> "This item is as unremarkable as can be." Just ItemDisco{itemKind} -> IK.idesc itemKind weight = jweight (itemBase itemFull) (scaledWeight, unitWeight) | weight > 1000 = (tshow $ fromIntegral weight / (1000 :: Double), "kg") | weight > 0 = (tshow weight, "g") | otherwise = ("", "") ln = abs $ fromEnum $ jlid (itemBase itemFull) colorSymbol = uncurry (flip Color.AttrChar) (viewItem $ itemBase itemFull) f = Color.AttrChar Color.defAttr lxsize = fst normalLevelBound + 1 -- TODO blurb = "D" -- dummy <+> nstats <> ":" <+> desc <+> makeSentence ["Weighs", MU.Text scaledWeight <> unitWeight] <+> makeSentence ["First 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} ) LambdaHack-0.5.0.0/Game/LambdaHack/Common/Ability.hs0000644000000000000000000000350212555256425020023 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} -- | AI strategy abilities. module Game.LambdaHack.Common.Ability ( Ability(..), Skills , zeroSkills, unitSkills, addSkills, scaleSkills , blockOnly, meleeAdjacent, meleeAndRanged, ignoreItems ) 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.empty 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 *) minusTen, blockOnly, meleeAdjacent, meleeAndRanged, ignoreItems :: Skills -- To make sure only a lot of weak items can override move-only-leader, etc. minusTen = EM.fromList $ zip [minBound..maxBound] [-10, -10..] blockOnly = EM.delete AbWait minusTen meleeAdjacent = EM.delete AbMelee blockOnly -- Melee and reaction fire. meleeAndRanged = EM.delete AbProject meleeAdjacent ignoreItems = EM.fromList $ zip [AbMoveItem, AbProject, AbApply] [-10, -10..] 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 = "apply" show AbTrigger = "trigger floor" instance Binary Ability where put = putWord8 . toEnum . fromEnum get = fmap (toEnum . fromEnum) getWord8 instance Hashable Ability LambdaHack-0.5.0.0/Game/LambdaHack/Common/EffectDescription.hs0000644000000000000000000001633312555256425022034 0ustar0000000000000000-- | 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 Data.EnumMap.Strict as EM 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 Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.Msg import Game.LambdaHack.Common.Time import Game.LambdaHack.Content.ItemKind -- | 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. effectToSuff :: Effect -> Text effectToSuff effect = case effect of NoEffect _ -> "" -- printed specially Hurt dice -> wrapInParens (tshow dice) Burn d -> wrapInParens (tshow d <+> if d > 1 then "burns" else "burn") Explode t -> "of" <+> tshow t <+> "explosion" RefillHP p | p > 0 -> "of limited healing" <+> wrapInParens (affixBonus p) RefillHP 0 -> assert `failure` effect RefillHP p -> "of limited wounding" <+> wrapInParens (affixBonus p) OverfillHP p | p > 0 -> "of healing" <+> wrapInParens (affixBonus p) OverfillHP 0 -> assert `failure` effect OverfillHP p -> "of wounding" <+> wrapInParens (affixBonus p) RefillCalm p | p > 0 -> "of limited soothing" <+> wrapInParens (affixBonus p) RefillCalm 0 -> assert `failure` effect RefillCalm p -> "of limited dismaying" <+> wrapInParens (affixBonus p) OverfillCalm p | p > 0 -> "of soothing" <+> wrapInParens (affixBonus p) OverfillCalm 0 -> assert `failure` effect OverfillCalm p -> "of dismaying" <+> wrapInParens (affixBonus p) Dominate -> "of domination" Impress -> "of impression" CallFriend 1 -> "of aid calling" CallFriend dice -> "of aid calling" <+> wrapInParens (tshow dice <+> "friends") Summon _freqs 1 -> "of summoning" -- TODO Summon _freqs dice -> "of summoning" <+> wrapInParens (tshow dice <+> "actors") ApplyPerfume -> "of smell removal" Ascend 1 -> "of ascending" Ascend p | p > 0 -> "of ascending for" <+> tshow p <+> "levels" Ascend 0 -> assert `failure` effect Ascend (-1) -> "of descending" Ascend p -> "of descending for" <+> tshow (-p) <+> "levels" Escape{} -> "of escaping" Paralyze dice -> let time = case Dice.reduceDice dice of Nothing -> tshow dice Just p -> let clipInTurn = timeTurn `timeFit` timeClip seconds = 0.5 * fromIntegral p / fromIntegral clipInTurn :: Double in tshow seconds <> "s" in "of paralysis for" <+> time InsertMove dice -> let moves = case Dice.reduceDice dice of Nothing -> tshow dice <+> "moves" Just p -> makePhrase [MU.CarWs p "move"] in "of speed surge for" <+> moves Teleport dice | dice <= 0 -> assert `failure` effect Teleport dice | dice <= 9 -> "of blinking" <+> wrapInParens (tshow dice <+> "steps") Teleport dice -> "of teleport" <+> wrapInParens (tshow dice <+> "steps") CreateItem COrgan grp tim -> let stime = if tim == TimerNone then "" else "for" <+> tshow tim <> ":" in "(keep" <+> stime <+> tshow grp <> ")" CreateItem _ grp _ -> let object = if grp == "useful" then "" else tshow grp in "of" <+> object <+> "uncovering" DropItem COrgan grp True -> "of nullify" <+> tshow grp DropItem _ grp hit -> let grpText = tshow grp hitText = if hit then "smash" else "drop" in "of" <+> hitText <+> grpText -- TMI: <+> ppCStore store PolyItem -> "of repurpose on the ground" Identify -> "of identify on the ground" SendFlying tmod -> "of impact" <+> tmodToSuff "" tmod PushActor tmod -> "of pushing" <+> tmodToSuff "" tmod PullActor tmod -> "of pulling" <+> tmodToSuff "" tmod DropBestWeapon -> "of disarming" ActivateInv ' ' -> "of inventory burst" ActivateInv symbol -> "of burst '" <> T.singleton symbol <> "'" OneOf l -> let subject = if length l <= 5 then "marvel" else "wonder" in makePhrase ["of", MU.CardinalWs (length l) subject] OnSmash _ -> "" -- printed inside a separate section Recharging _ -> "" -- printed inside Periodic or Timeout Temporary _ -> "" 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 rawAspectToSuff :: Aspect Text -> Text rawAspectToSuff aspect = case aspect of Unique -> "" -- marked by capital letters in name Periodic{} -> "" -- printed specially Timeout{} -> "" -- printed specially AddHurtMelee t -> wrapInParens $ t <> "% melee" AddHurtRanged t -> wrapInParens $ t <> "% ranged" AddArmorMelee t -> "[" <> t <> "%]" AddArmorRanged t -> "{" <> t <> "%}" AddMaxHP t -> wrapInParens $ t <+> "HP" AddMaxCalm t -> wrapInParens $ t <+> "Calm" AddSpeed t -> wrapInParens $ t <+> "speed" AddSkills p -> let skillToSuff (skill, bonus) = (if bonus > 0 then "+" else "") <> tshow bonus <+> tshow skill in wrapInParens $ T.intercalate " " $ map skillToSuff $ EM.assocs p AddSight t -> wrapInParens $ t <+> "sight" AddSmell t -> wrapInParens $ t <+> "smell" AddLight t -> wrapInParens $ t <+> "light" featureToSuff :: Feature -> Text featureToSuff feat = case feat of Fragile -> wrapInChevrons "fragile" Durable -> wrapInChevrons "durable" ToThrow tmod -> wrapInChevrons $ tmodToSuff "flies" tmod Identified -> "" Applicable -> "" EqpSlot{} -> "" Precious -> wrapInChevrons "precious" Tactic tactics -> "overrides tactics to" <+> tshow tactics effectToSuffix :: Effect -> Text effectToSuffix = effectToSuff aspectToSuffix :: Aspect Int -> Text aspectToSuffix = rawAspectToSuff . fmap 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 -> Text kindEffectToSuffix = effectToSuffix kindAspectToSuffix :: Aspect Dice.Dice -> Text kindAspectToSuffix = rawAspectToSuff . fmap affixDice LambdaHack-0.5.0.0/Game/LambdaHack/Common/ItemStrongest.hs0000644000000000000000000002206312555256425021240 0ustar0000000000000000-- | 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, strengthCreateOrgan, strengthDropOrgan , strengthToThrow, strengthEqpSlot, strengthFromEqpSlot, strengthEffect , strongestSlotNoFilter, strongestSlot, sumSlotNoFilter, sumSkills -- * Assorted , totalRange, computeTrajectory, itemTrajectory , unknownMelee, allRecharging, stripRecharging, stripOnSmash ) where import Control.Applicative import Control.Exception.Assert.Sugar 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.Item import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.Time import Game.LambdaHack.Common.Vector import Game.LambdaHack.Content.ItemKind 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 just offer the mean of the dice. This is also correct -- for summation, on average. concatMap (f . fmap Dice.meanDice) 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) strengthEffect :: (Effect -> [b]) -> ItemFull -> [b] {-# INLINE strengthEffect #-} strengthEffect f itemFull = case itemDisco itemFull of Just ItemDisco{itemAE=Just ItemAspectEffect{jeffects}} -> concatMap f jeffects Just ItemDisco{itemKind=ItemKind{ieffects}} -> concatMap f ieffects Nothing -> [] strengthFeature :: (Feature -> [b]) -> Item -> [b] strengthFeature f item = concatMap f (jfeature item) strengthOnSmash :: ItemFull -> [Effect] strengthOnSmash = let p (OnSmash eff) = [eff] p _ = [] in strengthEffect p strengthCreateOrgan :: ItemFull -> [GroupName ItemKind] strengthCreateOrgan = let p (CreateItem COrgan grp _) = [grp] p (Recharging (CreateItem COrgan grp _)) = [grp] p _ = [] in strengthEffect p strengthDropOrgan :: ItemFull -> [GroupName ItemKind] strengthDropOrgan = let p (DropItem COrgan grp _) = [grp] p (Recharging (DropItem COrgan grp _)) = [grp] p _ = [] in strengthEffect p strengthPeriodic :: ItemFull -> Maybe Int strengthPeriodic itemFull = let p Periodic = [()] p _ = [] isPeriodic = isJust $ strengthAspectMaybe p itemFull q (Timeout k) = [k] q _ = [] in if isPeriodic then strengthAspectMaybe q itemFull else Nothing strengthTimeout :: ItemFull -> Maybe Int strengthTimeout = let p (Timeout 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 strengthAllAddSkills :: ItemFull -> Maybe Ability.Skills strengthAllAddSkills = let p (AddSkills a) = [a] p _ = [] in strengthAspectMaybe p strengthAddSkills :: Ability.Ability -> ItemFull -> Maybe Int strengthAddSkills ab = let p (AddSkills a) = [EM.findWithDefault 0 ab 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 EqpSlotTimeout -> strengthTimeout EqpSlotAddMaxHP -> strengthAddMaxHP EqpSlotAddMaxCalm -> strengthAddMaxCalm EqpSlotAddSpeed -> strengthAddSpeed EqpSlotAddSkills ab -> strengthAddSkills ab EqpSlotAddHurtMelee -> strengthAddHurtMelee EqpSlotAddHurtRanged -> strengthAddHurtRanged EqpSlotAddArmorMelee -> strengthAddArmorMelee EqpSlotAddArmorRanged -> strengthAddArmorRanged EqpSlotAddSight -> strengthAddSight EqpSlotAddSmell -> strengthAddSmell EqpSlotAddLight -> strengthAddLight EqpSlotWeapon -> strengthMelee strengthMelee :: ItemFull -> Maybe Int strengthMelee itemFull = let p (Hurt d) = [Dice.meanDice d] p (Burn d) = [Dice.meanDice d] p _ = [] psum = sum (strengthEffect p itemFull) in if psum == 0 then Nothing else Just psum 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 = 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) <$> strengthAllAddSkills itemFull in foldr Ability.addSkills Ability.zeroSkills $ mapMaybe g is 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 allRecharging :: [Effect] -> [Effect] allRecharging effs = let getRechargingEffect :: Effect -> Maybe Effect getRechargingEffect e@Recharging{} = Just e getRechargingEffect _ = Nothing in mapMaybe getRechargingEffect effs stripRecharging :: [Effect] -> [Effect] stripRecharging effs = let getRechargingEffect :: Effect -> Maybe Effect getRechargingEffect (Recharging e) = Just e getRechargingEffect _ = Nothing in mapMaybe getRechargingEffect effs stripOnSmash :: [Effect] -> [Effect] stripOnSmash effs = let getOnSmashEffect :: Effect -> Maybe Effect getOnSmashEffect (OnSmash e) = Just e getOnSmashEffect _ = Nothing in mapMaybe getOnSmashEffect effs LambdaHack-0.5.0.0/Game/LambdaHack/Common/Dice.hs0000644000000000000000000001773512555256425017307 0ustar0000000000000000{-# LANGUAGE CPP, 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, diceMult, (|*|) , d, ds, dl, intToDice , maxDice, minDice, meanDice, reduceDice -- * Dice for rolling a pair of integer parameters representing coordinates. , DiceXY(..), maxDiceXY, minDiceXY, meanDiceXY #ifdef EXPOSE_INTERNAL -- * Internal operations , SimpleDice #endif ) where import Control.Applicative import Control.DeepSeq import Data.Binary import qualified Data.Char as Char import Data.Hashable (Hashable) import qualified Data.IntMap.Strict as IM import Data.Maybe 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 -- algebraic 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 | nameFrequency fra == "0" = (if name == "+" then "" else name) <+> nameFrequency frb | nameFrequency frb == "0" = nameFrequency fra | otherwise = 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] dieLevelSimple :: Int -> SimpleDice dieLevelSimple n = uniformFreq ("ds" <> tshow n) [1..n] zdieLevelSimple :: Int -> SimpleDice zdieLevelSimple n = uniformFreq ("zl" <> 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 , diceMult :: Int } deriving (Read, Eq, Ord, Generic) -- Read and Show should be inverses in this case. instance Show Dice where show Dice{..} = T.unpack $ let rawMult = nameFrequency diceLevel scaled = if rawMult == "0" then "" else rawMult signAndMult = case T.uncons scaled of Just ('-', _) -> scaled _ -> "+" <+> scaled in (if nameFrequency diceLevel == "0" then nameFrequency diceConst else if nameFrequency diceConst == "0" then scaled else nameFrequency diceConst <+> signAndMult) <+> if diceMult == 1 then "" else "|*|" <+> tshow diceMult instance Hashable Dice instance Binary Dice instance NFData 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) 0 1 affectBothDice :: (SimpleDice -> SimpleDice) -> Dice -> Dice affectBothDice f (Dice dc1 dl1 ds1) = Dice (f dc1) (f dl1) ds1 -- | A single simple dice. d :: Int -> Dice d n = Dice (dieSimple n) 0 1 -- | Dice scaled with level. ds :: Int -> Dice ds n = Dice 0 (dieLevelSimple n) 1 dl :: Int -> Dice dl = ds -- Not exposed to save on documentation. _z :: Int -> Dice _z n = Dice (zdieSimple n) 0 1 _zl :: Int -> Dice _zl n = Dice 0 (zdieLevelSimple n) 1 intToDice :: Int -> Dice intToDice = fromInteger . fromIntegral infixl 5 |*| -- | Multiplying the dice, after all randomness is resolved, by a constant. -- Infix declaration ensures that @1 + 2 |*| 3@ parses as @(1 + 2) |*| 3@. (|*|) :: Dice -> Int -> Dice Dice dc1 dl1 ds1 |*| s2 = Dice dc1 dl1 (ds1 * s2) -- | Maximal value of dice. The scaled part taken assuming maximum level. maxDice :: Dice -> Int maxDice Dice{..} = (fromMaybe 0 (maxFreq diceConst) + fromMaybe 0 (maxFreq diceLevel)) * diceMult -- | Minimal value of dice. The scaled part ignored. minDice :: Dice -> Int minDice Dice{..} = fromMaybe 0 (minFreq diceConst) * diceMult -- | Mean value of dice. The level-dependent part is taken assuming -- the highest level, because that's where the game is the hardest. -- Assumes the frequencies are not null. meanDice :: Dice -> Int meanDice Dice{..} = (meanFreq diceConst + meanFreq diceLevel) * diceMult reduceDice :: Dice -> Maybe Int reduceDice de = let minD = minDice de in if minD == maxDice de then Just minD 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 -> (Int, Int) meanDiceXY (DiceXY x y) = (meanDice x, meanDice y) LambdaHack-0.5.0.0/Game/LambdaHack/Common/RingBuffer.hs0000644000000000000000000000241312555256425020457 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} -- | Ring buffers. module Game.LambdaHack.Common.RingBuffer ( RingBuffer(rbLength) , empty, cons, uncons, toList ) where import Data.Binary import qualified Data.Vector as V import Data.Vector.Binary () import GHC.Generics (Generic) data RingBuffer a = RingBuffer { rbCarrier :: !(V.Vector a) , rbNext :: !Int , rbLength :: !Int } deriving (Show, Generic) instance Binary a => Binary (RingBuffer a) empty :: Int -> a -> RingBuffer a empty size dummy = RingBuffer (V.replicate size dummy) 0 0 cons :: a -> RingBuffer a -> RingBuffer a cons a RingBuffer{..} = let size = V.length rbCarrier incNext = (rbNext + 1) `mod` size incLength = min size $ rbLength + 1 in RingBuffer (rbCarrier V.// [(rbNext, a)]) incNext incLength uncons :: RingBuffer a -> Maybe (a, RingBuffer a) uncons RingBuffer{..} = let size = V.length rbCarrier decNext = (rbNext - 1) `mod` size in if rbLength == 0 then Nothing else Just ( rbCarrier V.! decNext , RingBuffer rbCarrier decNext (rbLength - 1) ) toList :: RingBuffer a -> [a] toList RingBuffer{..} = let l = V.toList rbCarrier size = V.length rbCarrier start = (rbNext + size - rbLength) `mod` size in take rbLength $ drop start $ l ++ l LambdaHack-0.5.0.0/Game/LambdaHack/Common/ClientOptions.hs0000644000000000000000000000375312555256425021230 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} -- | Screen frames and animations. module Game.LambdaHack.Common.ClientOptions ( DebugModeCli(..), defDebugModeCli ) where import Data.Binary import GHC.Generics (Generic) data DebugModeCli = DebugModeCli { sfont :: !(Maybe String) -- ^ Font to use for the main game window. , scolorIsBold :: !(Maybe Bool) -- ^ Whether to use bold attribute for colorful characters. , 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. , 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. , 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 , scolorIsBold = Nothing , smaxFps = Nothing , snoDelay = False , sdisableAutoYes = False , snoAnim = Nothing , snewGameCli = False , sbenchmark = False , ssavePrefixCli = Nothing , sfrontendStd = False , sfrontendNull = False , sdbgMsgCli = False } LambdaHack-0.5.0.0/Game/LambdaHack/Common/Tile.hs0000644000000000000000000002601412555256425017326 0ustar0000000000000000{-# LANGUAGE CPP, TypeFamilies #-} -- | 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 , isPassable, isPassableNoSuspect, isDoor, isSuspect , isExplorable, lookSimilar, speedup , openTo, closeTo, embedItems, causeEffects, revealAs, hideAs , isOpenable, isClosable, isChangeable, isEscape, isStair, ascendTo #ifdef EXPOSE_INTERNAL -- * Internal operations , TileSpeedup(..), Tab, createTab, accessTab #endif ) where import Control.Applicative import Control.Exception.Assert.Sugar import qualified Data.Array.Unboxed as A import Data.Maybe import qualified Game.LambdaHack.Common.Kind as Kind import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.Random import Game.LambdaHack.Common.Time import Game.LambdaHack.Content.ItemKind (ItemKind) import qualified Game.LambdaHack.Content.ItemKind as IK import Game.LambdaHack.Content.TileKind (TileKind) import qualified Game.LambdaHack.Content.TileKind as TK -- | The last time a hero left a smell in a given tile. To be used -- by monsters that hunt by smell. type SmellTime = Time type instance Kind.Speedup TileKind = TileSpeedup data TileSpeedup = TileSpeedup { isClearTab :: !Tab , isLitTab :: !Tab , isWalkableTab :: !Tab , isPassableTab :: !Tab , isPassableNoSuspectTab :: !Tab , isDoorTab :: !Tab , isSuspectTab :: !Tab , isChangeableTab :: !Tab } newtype Tab = Tab (A.UArray (Kind.Id TileKind) Bool) createTab :: Kind.Ops TileKind -> (TileKind -> Bool) -> Tab createTab Kind.Ops{ofoldrWithKey, obounds} p = let f _ k acc = p k : acc clearAssocs = ofoldrWithKey f [] in Tab $ A.listArray obounds clearAssocs accessTab :: Tab -> Kind.Id TileKind -> Bool {-# INLINE accessTab #-} accessTab (Tab tab) ki = tab A.! ki -- | Whether a tile kind has the given feature. kindHasFeature :: TK.Feature -> TileKind -> Bool {-# INLINE kindHasFeature #-} kindHasFeature f t = f `elem` TK.tfeature t -- | Whether a tile kind (specified by its id) has the given feature. hasFeature :: Kind.Ops TileKind -> TK.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 TileSpeedup{isClearTab}} = accessTab isClearTab 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 TileSpeedup{isLitTab}} = accessTab isLitTab 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 TileSpeedup{isWalkableTab}} = accessTab isWalkableTab 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 TileSpeedup{isPassableTab}} = accessTab isPassableTab isPassable 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. isPassableNoSuspect :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool {-# INLINE isPassableNoSuspect #-} isPassableNoSuspect Kind.Ops{ospeedup = Just TileSpeedup{isPassableNoSuspectTab}} = accessTab isPassableNoSuspectTab isPassableNoSuspect 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 TileSpeedup{isDoorTab}} = accessTab isDoorTab 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 TileSpeedup{isSuspectTab}} = accessTab isSuspectTab 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 TileSpeedup{isChangeableTab}} = accessTab isChangeableTab 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 = TK.tsymbol t == TK.tsymbol u && TK.tname t == TK.tname u && TK.tcolor t == TK.tcolor u && TK.tcolor2 t == TK.tcolor2 u speedup :: Bool -> Kind.Ops TileKind -> TileSpeedup 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 = createTab cotile $ not . kindHasFeature TK.Impenetrable | otherwise = createTab cotile $ kindHasFeature TK.Clear isLitTab = createTab cotile $ not . kindHasFeature TK.Dark isWalkableTab = createTab cotile $ kindHasFeature TK.Walkable isPassableTab = createTab cotile $ isPassableKind True isPassableNoSuspectTab = createTab cotile $ isPassableKind False isDoorTab = createTab cotile $ \tk -> let getTo TK.OpenTo{} = True getTo TK.CloseTo{} = True getTo _ = False in any getTo $ TK.tfeature tk isSuspectTab = createTab cotile $ kindHasFeature TK.Suspect isChangeableTab = createTab cotile $ \tk -> let getTo TK.ChangeTo{} = True getTo _ = False in any getTo $ TK.tfeature tk in TileSpeedup {..} isPassableKind :: Bool -> TileKind -> Bool isPassableKind passSuspect tk = let getTo TK.Walkable = True getTo TK.OpenTo{} = True getTo TK.ChangeTo{} = True -- can change to passable and may have loot getTo TK.Suspect | passSuspect = True getTo _ = False in any getTo $ TK.tfeature tk openTo :: Kind.Ops TileKind -> Kind.Id TileKind -> Rnd (Kind.Id TileKind) openTo Kind.Ops{okind, opick} t = do let getTo (TK.OpenTo grp) acc = grp : acc getTo _ acc = acc case foldr getTo [] $ TK.tfeature $ okind t of [] -> return t groups -> do grp <- oneOf groups fromMaybe (assert `failure` grp) <$> opick grp (const True) closeTo :: Kind.Ops TileKind -> Kind.Id TileKind -> Rnd (Kind.Id TileKind) closeTo Kind.Ops{okind, opick} t = do let getTo (TK.CloseTo grp) acc = grp : acc getTo _ acc = acc case foldr getTo [] $ TK.tfeature $ okind t of [] -> return t groups -> do grp <- oneOf groups fromMaybe (assert `failure` grp) <$> opick grp (const True) embedItems :: Kind.Ops TileKind -> Kind.Id TileKind -> [GroupName ItemKind] embedItems Kind.Ops{okind} t = let getTo (TK.Embed eff) acc = eff : acc getTo _ acc = acc in foldr getTo [] $ TK.tfeature $ okind t causeEffects :: Kind.Ops TileKind -> Kind.Id TileKind -> [IK.Effect] causeEffects Kind.Ops{okind} t = let getTo (TK.Cause eff) acc = eff : acc getTo _ acc = acc in foldr getTo [] $ TK.tfeature $ okind t revealAs :: Kind.Ops TileKind -> Kind.Id TileKind -> Rnd (Kind.Id TileKind) revealAs Kind.Ops{okind, opick} t = do let getTo (TK.RevealAs grp) acc = grp : acc getTo _ acc = acc case foldr getTo [] $ TK.tfeature $ okind t of [] -> return t groups -> do grp <- oneOf groups fromMaybe (assert `failure` grp) <$> opick grp (const True) hideAs :: Kind.Ops TileKind -> Kind.Id TileKind -> Kind.Id TileKind hideAs Kind.Ops{okind, ouniqGroup} t = let getTo (TK.HideAs grp) _ = Just grp getTo _ acc = acc in case foldr getTo Nothing (TK.tfeature (okind t)) of Nothing -> t Just grp -> ouniqGroup grp -- | 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 TK.OpenTo{} = True getTo _ = False in any getTo $ TK.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 TK.CloseTo{} = True getTo _ = False in any getTo $ TK.tfeature $ okind t isEscape :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool isEscape cotile t = let isEffectEscape IK.Escape{} = True isEffectEscape _ = False in any isEffectEscape $ causeEffects cotile t isStair :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool isStair cotile t = let isEffectAscend IK.Ascend{} = True isEffectAscend _ = False in any isEffectAscend $ causeEffects cotile t ascendTo :: Kind.Ops TileKind -> Kind.Id TileKind -> [Int] ascendTo cotile t = let getTo (IK.Ascend k) acc = k : acc getTo _ acc = acc in foldr getTo [] (causeEffects cotile t) LambdaHack-0.5.0.0/Game/LambdaHack/Common/PointArray.hs0000644000000000000000000001637712555256425020534 0ustar0000000000000000{-# LANGUAGE CPP #-} -- | Arrays, based on Data.Vector.Unboxed, indexed by @Point@. module Game.LambdaHack.Common.PointArray ( Array , (!), (//), replicateA, replicateMA, generateA, generateMA, sizeA , foldlA, ifoldlA, mapA, imapA, mapWithKeyMA , safeSetA, unsafeSetA, unsafeUpdateA , minIndexA, minLastIndexA, minIndexesA, maxIndexA, maxLastIndexA, forceA ) where import Control.Arrow ((***)) import Control.Monad import Control.Monad.ST.Strict import Data.Binary import Data.Vector.Binary () #if MIN_VERSION_vector(0,11,0) import qualified Data.Vector.Fusion.Bundle as Bundle #else import qualified Data.Vector.Fusion.Stream as Bundle #endif import qualified Data.Vector.Generic as G import qualified Data.Vector.Unboxed as U import qualified Data.Vector.Unboxed.Mutable as VM 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 {-# INLINE cnv #-} cnv = toEnum . fromEnum pindex :: X -> Point -> Int {-# INLINE pindex #-} pindex xsize (Point x y) = x + y * xsize punindex :: X -> Int -> Point {-# INLINE punindex #-} 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 {-# INLINE (//) #-} (//) Array{..} l = let v = avector U.// map (pindex axsize *** cnv) l in Array{avector = v, ..} unsafeUpdateA :: Enum c => Array c -> [(Point, c)] -> Array c {-# INLINE unsafeUpdateA #-} unsafeUpdateA Array{..} l = runST $ do vThawed <- U.unsafeThaw avector mapM_ (\(p, c) -> VM.write vThawed (pindex axsize p) (cnv c)) l vFrozen <- U.unsafeFreeze vThawed return $! Array{avector = vFrozen, ..} -- | Create an array from a replicated element. replicateA :: Enum c => X -> Y -> c -> Array c {-# INLINE replicateA #-} 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) {-# INLINE replicateMA #-} replicateMA axsize aysize m = do v <- U.replicateM (axsize * aysize) $ liftM cnv m return $! Array{avector = v, ..} -- | Create an array from a function. generateA :: Enum c => X -> Y -> (Point -> c) -> Array c {-# INLINE generateA #-} generateA axsize aysize f = let g n = cnv $ f $ punindex axsize n in Array{avector = U.generate (axsize * aysize) g, ..} -- | Create an array from a monadic function. generateMA :: Enum c => Monad m => X -> Y -> (Point -> m c) -> m (Array c) {-# INLINE generateMA #-} 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) {-# INLINE sizeA #-} sizeA Array{..} = (axsize, aysize) -- | Fold left strictly over an array. foldlA :: Enum c => (a -> c -> a) -> a -> Array c -> a {-# INLINE foldlA #-} 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 {-# INLINE ifoldlA #-} ifoldlA f z0 Array{..} = U.ifoldl' (\a n c -> f a (punindex axsize n) (cnv c)) z0 avector -- | Map over an array. mapA :: (Enum c, Enum d) => (c -> d) -> Array c -> Array d {-# INLINE mapA #-} mapA f Array{..} = Array{avector = U.map (cnv . f . cnv) 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 {-# INLINE imapA #-} imapA f Array{..} = let v = U.imap (\n c -> cnv $ f (punindex axsize n) (cnv c)) avector in Array{avector = v, ..} -- | Set all elements to the given value, in place. unsafeSetA :: Enum c => c -> Array c -> Array c {-# INLINE unsafeSetA #-} unsafeSetA c Array{..} = runST $ do vThawed <- U.unsafeThaw avector VM.set vThawed (cnv c) vFrozen <- U.unsafeFreeze vThawed return $! Array{avector = vFrozen, ..} -- | Set all elements to the given value, in place, if possible. safeSetA :: Enum c => c -> Array c -> Array c {-# INLINE safeSetA #-} safeSetA c Array{..} = Array{avector = U.modify (\v -> VM.set v (cnv c)) avector, ..} -- | Map monadically over an array (function applied to each element -- and its index) and ignore the results. mapWithKeyMA :: Enum c => Monad m => (Point -> c -> m ()) -> Array c -> m () {-# INLINE mapWithKeyMA #-} mapWithKeyMA f Array{..} = U.ifoldl' (\a n c -> a >> f (punindex axsize n) (cnv c)) (return ()) avector -- | Yield the point coordinates of a minimum element of the array. -- The array may not be empty. minIndexA :: Enum c => Array c -> Point {-# INLINE minIndexA #-} minIndexA Array{..} = punindex axsize $ U.minIndex avector -- | Yield the point coordinates of the last minimum element of the array. -- The array may not be empty. minLastIndexA :: Enum c => Array c -> Point {-# INLINE minLastIndexA #-} minLastIndexA Array{..} = punindex axsize $ fst . 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 :: Enum c => Array c -> [Point] {-# INLINE minIndexesA #-} minIndexesA Array{..} = map (punindex axsize) $ Bundle.foldl' imin [] . Bundle.indexed . G.stream $ avector where imin acc (i, x) = i `seq` if x == minE then i : acc else acc minE = cnv $ U.minimum avector -- | 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 . 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 :: Enum c => Array c -> Array c {-# INLINE forceA #-} forceA Array{..} = Array{avector = U.force avector, ..} instance Binary (Array c) where put Array{..} = do put axsize put aysize put avector get = do axsize <- get aysize <- get avector <- get return $! Array{..} LambdaHack-0.5.0.0/Game/LambdaHack/Common/Vector.hs0000644000000000000000000002101712555256425017671 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} -- | 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.DeepSeq import Control.Exception.Assert.Sugar import Data.Binary import qualified Data.EnumMap.Strict as EM import Data.Int (Int32) import Data.Text (Text) import GHC.Generics (Generic) 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, Generic) 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 instance NFData Vector -- | 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) | x > maxVectorDim = (x - 2 ^ maxLevelDimExponent, y + 1) | x < - maxVectorDim = (x + 2 ^ maxLevelDimExponent, y - 1) | otherwise = (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] {-# NOINLINE moves #-} 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 assFail = assert `failure` "not a unit vector" `twith` v in EM.findWithDefault assFail 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 = if inside p (1, 1, lxsize - 2, lysize - 2) then vicinityUnsafe p else [ res | dxy <- moves , let res = shift p dxy , inside res (0, 0, lxsize - 1, lysize - 1) ] vicinityUnsafe :: Point -> [Point] vicinityUnsafe p = [ res | dxy <- moves , let res = shift p dxy ] -- | 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 LambdaHack-0.5.0.0/Game/LambdaHack/Common/Misc.hs0000644000000000000000000001745412555256425017334 0ustar0000000000000000{-# 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(..), ItemDialogMode(..) -- * Assorted , normalLevelBound, divUp, GroupName, toGroupName, Freqs, breturn , serverSaveName, Rarity, validateRarity, Tactic(..) -- * Backward compatibility , isRight ) where import Control.DeepSeq import Control.Monad import Data.Binary import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES import Data.Function import Data.Functor import Data.Hashable import qualified Data.HashMap.Strict as HM import Data.Key import Data.List import Data.Ord import Data.String (IsString (..)) import Data.Text (Text) import qualified Data.Text as T import Data.Traversable (traverse) import GHC.Generics (Generic) import qualified NLP.Miniutter.English as MU import Game.LambdaHack.Common.Point 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 {-# INLINE divUp #-} divUp n k = (n + k - 1) `div` k -- 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 a = GroupName Text deriving (Eq, Ord, Read, Hashable, Binary, Generic) instance IsString (GroupName a) where fromString = GroupName . T.pack instance Show (GroupName a) where show (GroupName gn) = T.unpack gn instance NFData (GroupName a) toGroupName :: Text -> GroupName a toGroupName = GroupName -- | 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 a = [(GroupName a, Int)] -- | Rarity on given depths. type Rarity = [(Double, Int)] validateRarity :: Rarity -> [Text] validateRarity rarity = let sortedRarity = sortBy (comparing fst) rarity in [ "rarity not sorted" | sortedRarity /= rarity ] ++ [ "rarity depth thresholds not unique" | nubBy ((==) `on` fst) sortedRarity /= sortedRarity ] ++ [ "rarity depth not between 0 and 10" | case (sortedRarity, reverse sortedRarity) of ((lowest, _) : _, (highest, _) : _) -> lowest <= 0 || highest > 10 _ -> False ] -- | @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 | CEmbed !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 instance NFData CStore data ItemDialogMode = MStore CStore | MOwned | MStats deriving (Show, Read, Eq, Ord, Generic) instance NFData ItemDialogMode -- | 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) -- TODO: there is already too many; express this somehow via skills; -- also, we risk micromanagement; perhaps only have as many tactics -- as needed for realistic AI behaviour in our game modes; -- perhaps even expose only some of them to UI; perhaps define tactics -- in rules content or in game mode defs; perhaps have skills corresponding -- to exploration. following, etc. -- | Tactic of non-leader actors. Apart of determining AI operation, -- each tactic implies a skill modifier, that is added to the non-leader skills -- defined in 'fskillsOther' field of 'Player'. data Tactic = 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 -- TODO (currently the same as TExplore; should it chase -- targets too (TRoam) and only switch to TPatrol when none?) deriving (Eq, Ord, Enum, Bounded, Generic) instance Show Tactic where show TExplore = "explore unknown, chase targets" show TFollow = "follow leader's target or position" show TFollowNoItems = "follow leader's target or position, ignore items" show TMeleeAndRanged = "only melee and perform ranged combat" show TMeleeAdjacent = "only melee" show TBlock = "only block and wait" show TRoam = "roam freely, chase targets" show TPatrol = "find and patrol an area (TODO)" instance Binary Tactic instance Hashable Tactic -- TODO: remove me when we no longer suppoert GHC 7.6.* isRight :: Either a b -> Bool isRight e = case e of Right{} -> True Left{} -> False -- 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) -- Control.DeepSeq instance NFData MU.Part instance NFData MU.Person instance NFData MU.Polarity LambdaHack-0.5.0.0/Game/LambdaHack/Common/Frequency.hs0000644000000000000000000001072512555256425020374 0ustar0000000000000000{-# 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.DeepSeq import Control.Exception.Assert.Sugar import Control.Monad import Data.Binary import Data.Foldable (Foldable) import qualified Data.Foldable as F import Data.Hashable (Hashable) import Data.Text (Text) import Data.Traversable (Traversable) import GHC.Generics (Generic) import Game.LambdaHack.Common.Misc 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). -- However, elements with 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, unless they do some kind of normalization -- (see 'Dice'). data Frequency a = Frequency { runFrequency :: ![(Int, a)] -- ^ give acces to raw frequency values , nameFrequency :: Text -- ^ short description for debug, etc.; -- keep it lazy, because it's rarely used } deriving (Show, Read, Eq, Ord, Foldable, Traversable, Generic) instance Monad Frequency where {-# INLINE return #-} return x = Frequency [(1, x)] "return" Frequency xs name >>= f = Frequency [ (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 pure = return Frequency fs fname <*> Frequency ys yname = Frequency [ (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 instance Hashable a => Hashable (Frequency a) instance Binary a => Binary (Frequency a) instance NFData a => NFData (Frequency a) -- | Uniform discrete frequency distribution. uniformFreq :: Text -> [a] -> Frequency a uniformFreq name l = Frequency (map (\x -> (1, x)) 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 = 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" `twith` (name, n, xs)) $ Frequency (map (first (* n)) xs) name -- | 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 xs name) x n = let xsNew = [(n, x) | n <= 0] ++ filter ((/= x) . snd) xs in Frequency xsNew name -- | Test if the frequency distribution is empty. nullFreq :: Frequency a -> Bool {-# INLINE nullFreq #-} nullFreq (Frequency fs _) = null fs maxFreq :: Ord a => Frequency a -> Maybe a {-# INLINE maxFreq #-} maxFreq fr = if nullFreq fr then Nothing else Just $ F.maximum fr minFreq :: Ord a => Frequency a -> Maybe a {-# INLINE minFreq #-} minFreq fr = if nullFreq fr then Nothing else Just $ F.minimum fr -- | Average value of an @Int@ distribution, rounded up to avoid truncating -- it in the other code higher up, which would equate 1d0 with 1d1. meanFreq :: Frequency Int -> Int {-# INLINE meanFreq #-} meanFreq fr@(Frequency xs _) = case xs of [] -> assert `failure` fr _ -> let sumX = sum [ p * x | (p, x) <- xs ] sumP = sum $ map fst xs in sumX `divUp` sumP LambdaHack-0.5.0.0/Game/LambdaHack/Common/ActorState.hs0000644000000000000000000004520712555256425020507 0ustar0000000000000000{-# LANGUAGE TupleSections #-} -- | 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 , mergeItemQuant, sharedAllOwnedFid, findIid , getCBag, getActorBag, getBodyActorBag, mapActorItems_, getActorAssocs , nearbyFreePoints, whereTo, getCarriedAssocs, getCarriedIidCStore , posToActors, getItemBody, memActor, getActorBody , tryFindHeroK, getLocalTime, itemPrice, regenCalmDelta , actorInAmbient, actorSkills, dispEnemy, fullAssocs, itemToFull , goesIntoEqp, goesIntoInv, goesIntoSha, eqpOverfull, eqpFreeN , storeFromC, lidFromC, aidFromC, hasCharge , strongestMelee, isMelee, isMeleeEqp ) where import Control.Applicative 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 Data.Ord as Ord import qualified Game.LambdaHack.Common.Ability as Ability import Game.LambdaHack.Common.Actor import qualified Game.LambdaHack.Common.Dice as Dice 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 qualified Game.LambdaHack.Content.ItemKind as IK import Game.LambdaHack.Content.ModeKind import Game.LambdaHack.Content.TileKind (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 = let assFail = assert `failure` "item body not found" `twith` (iid, s) in EM.findWithDefault assFail 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, ItemQuant))] bagAssocsK s bag = let iidItem (iid, kit) = (iid, (getItemBody iid s, kit)) in map iidItem $ EM.assocs bag -- | Finds all actors at a position on the current level. posToActors :: Point -> LevelId -> State -> [(ActorId, Actor)] posToActors pos lid s = let as = actorAssocs (const True) lid s l = filter (\(_, b) -> bpos b == pos) as in assert (length l <= 1 || all (bproj . snd) 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) mergeItemQuant :: ItemQuant -> ItemQuant -> ItemQuant mergeItemQuant (k1, it1) (k2, it2) = (k1 + k2, it1 ++ it2) sharedInv :: Actor -> State -> ItemBag sharedInv body s = let bs = fidActorNotProjList (bfid body) s in EM.unionsWith mergeItemQuant $ 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 mergeItemQuant $ 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 mergeItemQuant [sharedEqp body s, sharedInv body s, shaBag] sharedAllOwnedFid :: Bool -> FactionId -> State -> ItemBag sharedAllOwnedFid onlyOrgans fid s = let shaBag = gsha $ sfactionD s EM.! fid bs = fidActorNotProjList fid s in EM.unionsWith mergeItemQuant $ if onlyOrgans then map borgan bs else map binv bs ++ map beqp bs ++ [shaBag] findIid :: ActorId -> FactionId -> ItemId -> State -> [(Actor, CStore)] findIid leader fid iid s = let actors = fidActorNotProjAssocs fid s itemsOfActor (aid, b) = let itemsOfCStore store = let bag = getBodyActorBag b store s in map (\iid2 -> (iid2, (b, store))) (EM.keys bag) stores = [CInv, CEqp] ++ [CSha | aid == leader] in concatMap itemsOfCStore stores items = concatMap itemsOfActor actors in map snd $ filter ((== iid) . fst) items -- | 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 :: FactionId -> Int -> State -> Maybe (ActorId, Actor) tryFindHeroK fact k s = 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 = let assFail = assert `failure` "body not found" `twith` (aid, s) in EM.findWithDefault assFail aid $ sactorD s getCarriedAssocs :: Actor -> State -> [(ItemId, Item)] getCarriedAssocs b s = bagAssocs s $ EM.unionsWith const [binv b, beqp b, borgan b] getCarriedIidCStore :: Actor -> [(ItemId, CStore)] getCarriedIidCStore b = let bagCarried (cstore, bag) = map (,cstore) $ EM.keys bag in concatMap bagCarried [(CInv, binv b), (CEqp, beqp b), (COrgan, borgan b)] getCBag :: Container -> State -> ItemBag {-# INLINE getCBag #-} getCBag c s = case c of CFloor lid p -> EM.findWithDefault EM.empty p $ lfloor (sdungeon s EM.! lid) CEmbed lid p -> EM.findWithDefault EM.empty p $ lembed (sdungeon s EM.! lid) CActor aid cstore -> getActorBag aid cstore s CTrunk{} -> assert `failure` c getActorBag :: ActorId -> CStore -> State -> ItemBag {-# INLINE getActorBag #-} getActorBag aid cstore s = let b = getActorBody aid s in getBodyActorBag b cstore s getBodyActorBag :: Actor -> CStore -> State -> ItemBag {-# INLINE getBodyActorBag #-} getBodyActorBag b cstore s = case cstore of CGround -> EM.findWithDefault EM.empty (bpos b) $ lfloor (sdungeon s EM.! blid b) COrgan -> borgan b CEqp -> beqp b CInv -> binv b CSha -> gsha $ sfactionD s EM.! bfid b mapActorItems_ :: Monad m => (CStore -> ItemId -> ItemQuant -> m a) -> Actor -> State -> m () mapActorItems_ f b s = do let notProcessed = [CGround] sts = [minBound..maxBound] \\ notProcessed g cstore = do let bag = getBodyActorBag b cstore s mapM_ (uncurry $ f cstore) $ EM.assocs bag mapM_ g sts getActorAssocs :: ActorId -> CStore -> State -> [(ItemId, Item)] getActorAssocs aid cstore s = bagAssocs s $ getActorBag aid cstore s getActorAssocsK :: ActorId -> CStore -> State -> [(ItemId, (Item, ItemQuant))] 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 -- | 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 IK.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 steps. 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 :: Maybe ActorId -> ActorId -> [ItemFull] -> State -> Ability.Skills actorSkills mleader aid activeItems s = let body = getActorBody aid s player = gplayer . (EM.! bfid body) . sfactionD $ s skillsFromTactic = tacticSkills $ ftactic player factionSkills | Just aid == mleader = Ability.zeroSkills | otherwise = fskillsOther player `Ability.addSkills` skillsFromTactic itemSkills = sumSkills activeItems in itemSkills `Ability.addSkills` factionSkills tacticSkills :: Tactic -> Ability.Skills tacticSkills TExplore = Ability.zeroSkills tacticSkills TFollow = Ability.zeroSkills tacticSkills TFollowNoItems = Ability.ignoreItems tacticSkills TMeleeAndRanged = Ability.meleeAndRanged tacticSkills TMeleeAdjacent = Ability.meleeAdjacent tacticSkills TBlock = Ability.blockOnly tacticSkills TRoam = Ability.zeroSkills tacticSkills TPatrol = Ability.zeroSkills -- 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 actorMaxSk = sumSkills activeItems sb = getActorBody source s tb = getActorBody target s in bproj tb || not (actorDying tb || braced tb || EM.findWithDefault 0 Ability.AbMove actorMaxSk <= 0 || hasSupport sb && hasSupport tb) -- solo actors are flexible fullAssocs :: Kind.COps -> DiscoveryKind -> DiscoveryEffect -> ActorId -> [CStore] -> State -> [(ItemId, ItemFull)] fullAssocs cops disco discoEffect aid cstores s = let allAssocs = concatMap (\cstore -> getActorAssocsK aid cstore s) cstores iToFull (iid, (item, kit)) = (iid, itemToFull cops disco discoEffect iid item kit) in map iToFull allAssocs itemToFull :: Kind.COps -> DiscoveryKind -> DiscoveryEffect -> ItemId -> Item -> ItemQuant -> ItemFull itemToFull Kind.COps{coitem=Kind.Ops{okind}} disco discoEffect iid itemBase (itemK, itemTimer) = let itemDisco = case EM.lookup (jkindIx itemBase) disco of Nothing -> Nothing Just itemKindId -> Just ItemDisco{ itemKindId , itemKind = okind itemKindId , itemAE = EM.lookup iid discoEffect } in ItemFull {..} -- Non-durable item that hurts doesn't go into equipment by default, -- but if it is in equipment or among organs, it's used for melee -- nevertheless, e.g., thorns. goesIntoEqp :: ItemFull -> Bool goesIntoEqp itemFull = isJust (strengthEqpSlot $ itemBase itemFull) -- TODO: not needed if EqpSlotWeapon stays || isMeleeEqp itemFull) goesIntoInv :: ItemFull -> Bool goesIntoInv itemFull = IK.Precious `notElem` jfeature (itemBase itemFull) && not (goesIntoEqp itemFull) goesIntoSha :: ItemFull -> Bool goesIntoSha itemFull = IK.Precious `elem` jfeature (itemBase itemFull) && not (goesIntoEqp itemFull) 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 storeFromC :: Container -> CStore storeFromC c = case c of CFloor{} -> CGround CEmbed{} -> CGround CActor _ cstore -> cstore CTrunk{} -> assert `failure` c -- | Determine the dungeon level of the container. If the item is in a shared -- stash, the level depends on which actor asks. lidFromC :: Container -> State -> LevelId lidFromC (CFloor lid _) _ = lid lidFromC (CEmbed lid _) _ = lid lidFromC (CActor aid _) s = blid $ getActorBody aid s lidFromC c@CTrunk{} _ = assert `failure` c aidFromC :: Container -> Maybe ActorId aidFromC CFloor{} = Nothing aidFromC CEmbed{} = Nothing aidFromC (CActor aid _) = Just aid aidFromC c@CTrunk{} = assert `failure` c hasCharge :: Time -> ItemFull -> Bool hasCharge localTime itemFull@ItemFull{..} = let it1 = case strengthFromEqpSlot IK.EqpSlotTimeout itemFull of Nothing -> [] -- if item not IDed, assume no timeout, to ID by use Just timeout -> let timeoutTurns = timeDeltaScale (Delta timeTurn) timeout charging startT = timeShift startT timeoutTurns > localTime in filter charging itemTimer len = length it1 in len < itemK strMelee :: Bool -> Time -> ItemFull -> Maybe Int strMelee effectBonus localTime itemFull = let durable = IK.Durable `elem` jfeature (itemBase itemFull) recharged = hasCharge localTime itemFull -- We assume extra weapon effects are useful and so such -- weapons are preferred over weapons with no effects. -- If the player doesn't like a particular weapon's extra effect, -- he has to manage this manually. p (IK.Hurt d) = [Dice.meanDice d] p (IK.Burn d) = [Dice.meanDice d] p IK.NoEffect{} = [] p IK.OnSmash{} = [] -- Hackish extra bonus to force Summon as first effect used -- before Calm of enemy is depleted. p (IK.Recharging IK.Summon{}) = [999 | recharged && effectBonus] -- We assume the weapon is still worth using, even if some effects -- are charging; in particular, we assume Hurt or Burn are not -- under Recharging. p IK.Recharging{} = [100 | recharged && effectBonus] p IK.Temporary{} = [] p _ = [100 | effectBonus] psum = sum (strengthEffect p itemFull) in if not (isMelee itemFull) || psum == 0 then Nothing else Just $ psum + if durable then 1000 else 0 strongestMelee :: Bool -> Time -> [(ItemId, ItemFull)] -> [(Int, (ItemId, ItemFull))] strongestMelee effectBonus localTime is = let f = strMelee effectBonus localTime g (iid, itemFull) = (\v -> (v, (iid, itemFull))) <$> f itemFull in sortBy (flip $ Ord.comparing fst) $ mapMaybe g is isMelee :: ItemFull -> Bool isMelee itemFull = let p IK.Hurt{} = True p IK.Burn{} = True p _ = False in case itemDisco itemFull of Just ItemDisco{itemAE=Just ItemAspectEffect{jeffects}} -> any p jeffects Just ItemDisco{itemKind=IK.ItemKind{IK.ieffects}} -> any p ieffects Nothing -> False -- Melee weapon so good (durable) that goes into equipment by default. isMeleeEqp :: ItemFull -> Bool isMeleeEqp itemFull = let durable = IK.Durable `elem` jfeature (itemBase itemFull) in isMelee itemFull && durable LambdaHack-0.5.0.0/Game/LambdaHack/Common/Actor.hs0000644000000000000000000002303612555256425017502 0ustar0000000000000000-- | 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, braced, waitedLastTurn , actorDying, actorNewBorn, unoccupied , hpTooLow, hpHuge, calmEnough, calmEnough10, hpEnough, hpEnough10 -- * Assorted , ActorDict, smellTimeout, checkAdjacent , keySelected, ppContainer, ppCStore, ppCStoreIn, verbCStore ) where import Control.Exception.Assert.Sugar import Data.Binary import qualified Data.EnumMap.Strict as EM import Data.Int (Int64) import Data.Maybe import Data.Ratio import Data.Text (Text) import qualified NLP.Miniutter.English as MU import qualified Game.LambdaHack.Common.Color as Color import Game.LambdaHack.Common.Item import Game.LambdaHack.Common.ItemStrongest import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.Msg import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.Random import Game.LambdaHack.Common.Time import Game.LambdaHack.Common.Vector import qualified Game.LambdaHack.Content.ItemKind as IK -- | 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 :: !(Maybe Point) -- ^ previous position, if any , blid :: !LevelId -- ^ current level , boldlid :: !LevelId -- ^ previous level , bfid :: !FactionId -- ^ faction the actor currently belongs to , bfidImpressed :: !FactionId -- ^ the faction actor is attracted to , bfidOriginal :: !FactionId -- ^ the original 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 -> Int -> Rnd Bool monsterGenChance _ _ _ 0 = return False monsterGenChance (AbsDepth n) (AbsDepth totalDepth) lvlSpawned actorCoeff = assert (totalDepth > 0 && n > 0) -- Mimics @castDice@. On level 5/10, first 6 monsters appear fast. $ let scaledDepth = n * 10 `div` totalDepth -- Heroes have to endure two lvl-sized waves of spawners for each level. numSpawnedCoeff = lvlSpawned `div` 2 in chance $ 1%(fromIntegral ((actorCoeff * (numSpawnedCoeff - scaledDepth)) `max` 1)) -- | 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 = Nothing boldlid = blid beqp = EM.empty binv = EM.empty borgan = EM.empty bwait = False bfidImpressed = bfid bfidOriginal = 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 IK.EqpSlotAddSpeed activeItems Just (_, speed) -> speed -- | Whether an actor is braced for combat this clip. braced :: Actor -> Bool braced = bwait -- | The actor waited last turn. waitedLastTurn :: Actor -> Bool waitedLastTurn = bwait actorDying :: Actor -> Bool actorDying b = bhp b <= 0 || bproj b && maybe True (null . fst) (btrajectory b) actorNewBorn :: Actor -> Bool actorNewBorn b = isNothing (boldpos b) && not (waitedLastTurn b) && btime b >= timeTurn hpTooLow :: Actor -> [ItemFull] -> Bool hpTooLow b activeItems = let maxHP = sumSlotNoFilter IK.EqpSlotAddMaxHP activeItems in bhp b <= oneM || 5 * bhp b < xM maxHP && bhp b <= xM 10 hpHuge :: Actor -> Bool hpHuge b = bhp b > xM 40 calmEnough :: Actor -> [ItemFull] -> Bool calmEnough b activeItems = let calmMax = max 1 $ sumSlotNoFilter IK.EqpSlotAddMaxCalm activeItems in 2 * xM calmMax <= 3 * bcalm b calmEnough10 :: Actor -> [ItemFull] -> Bool calmEnough10 b activeItems = calmEnough b activeItems && bcalm b > xM 10 hpEnough :: Actor -> [ItemFull] -> Bool hpEnough b activeItems = let hpMax = max 1 $ sumSlotNoFilter IK.EqpSlotAddMaxHP activeItems in xM hpMax <= 3 * bhp b hpEnough10 :: Actor -> [ItemFull] -> Bool hpEnough10 b activeItems = hpEnough b activeItems && bhp b > xM 10 -- | 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) keySelected :: (ActorId, Actor) -> (Bool, Bool, Char, Color.Color, ActorId) keySelected (aid, Actor{bsymbol, bcolor, bhp}) = (bhp > 0, bsymbol /= '@', bsymbol, bcolor, aid) ppContainer :: Container -> Text ppContainer CFloor{} = "nearby" ppContainer CEmbed{} = "embedded nearby" ppContainer (CActor _ cstore) = ppCStoreIn cstore ppContainer c@CTrunk{} = assert `failure` c ppCStore :: CStore -> (Text, Text) ppCStore CGround = ("on", "the ground") ppCStore COrgan = ("among", "organs") ppCStore CEqp = ("in", "equipment") ppCStore CInv = ("in", "pack") ppCStore CSha = ("in", "shared stash") ppCStoreIn :: CStore -> Text ppCStoreIn c = let (tIn, t) = ppCStore c in tIn <+> t verbCStore :: CStore -> Text verbCStore CGround = "drop" verbCStore COrgan = "implant" verbCStore CEqp = "equip" verbCStore CInv = "pack" verbCStore CSha = "stash" 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 bfidImpressed put bfidOriginal 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 bfidImpressed <- get bfidOriginal <- get bproj <- get return $! Actor{..} instance Binary ResDelta where put ResDelta{..} = do put resCurrentTurn put resPreviousTurn get = do resCurrentTurn <- get resPreviousTurn <- get return $! ResDelta{..} LambdaHack-0.5.0.0/Game/LambdaHack/Server/0000755000000000000000000000000012555256425016110 5ustar0000000000000000LambdaHack-0.5.0.0/Game/LambdaHack/Server/StartServer.hs0000644000000000000000000004055412555256425020740 0ustar0000000000000000-- | Operations for starting and restarting the game. module Game.LambdaHack.Server.StartServer ( gameReset, reinitGame, initPer, recruitActors, applyDebug, initDebug ) where import Control.Applicative 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.Ord 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 Game.LambdaHack.Common.Faction 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.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.State import qualified Game.LambdaHack.Common.Tile as Tile import Game.LambdaHack.Common.Time import Game.LambdaHack.Content.ItemKind (ItemKind) import qualified Game.LambdaHack.Content.ItemKind as IK import Game.LambdaHack.Content.ModeKind import Game.LambdaHack.Content.RuleKind import qualified Game.LambdaHack.Content.TileKind as TK 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 DebugModeSer{scurDiffSer, sknowMap, sdebugCli} <- getsServer 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 | sknowMap = s | otherwise = localFromGlobal s discoS <- getsServer sdiscoKind let sdiscoKind = let f ik = IK.Identified `elem` IK.ifeature (okind ik) in EM.filter f discoS broadcastUpdAtomic $ \fid -> UpdRestart fid sdiscoKind (pers EM.! fid) defLocal scurDiffSer sdebugCli 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 :: AbsDepth -> Roster -> Rnd FactionDict createFactions totalDepth players = do let rawCreate Player{..} = do entryLevel <- castDice (AbsDepth 0) (AbsDepth 0) fentryLevel initialActors <- castDice (AbsDepth $ abs entryLevel) totalDepth finitialActors let gplayer = Player{ fentryLevel = entryLevel , finitialActors = initialActors , ..} cmap = mapFromFuns [colorToTeamName, colorToPlainName, colorToFancyName] nameoc = lowercase $ head $ T.words fname prefix = case fleaderMode of LeaderNull -> "Loose" LeaderAI _ -> "Autonomous" LeaderUI _ -> "Controlled" (gcolor, gname) = case M.lookup nameoc cmap of Nothing -> (Color.BrWhite, prefix <+> fname) Just c -> (c, prefix <+> fname <+> "Team") let gdipl = EM.empty -- fixed below gquit = Nothing gleader = Nothing gvictims = EM.empty gsha = EM.empty return $! Faction{..} lUI <- mapM rawCreate $ filter fhasUI $ rosterList players lnoUI <- mapM rawCreate $ filter (not . fhasUI) $ rosterList players let lFs = reverse (zip [toEnum (-1), toEnum (-2)..] lnoUI) -- sorted ++ zip [toEnum 1..] lUI swapIx l = let findPlayerName name = find ((name ==) . fname . 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 (rosterAlly players)) warFs = mkDipl War allianceFs (swapIx (rosterEnemy players)) return $! warFs gameReset :: MonadServer m => Kind.COps -> DebugModeSer -> Maybe (GroupName ModeKind) -> Maybe R.StdGen -> m State gameReset cops@Kind.COps{comode=Kind.Ops{opick, okind}} sdebug mGameMode 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 gameMode = fromMaybe "starting" $ mGameMode `mplus` sgameMode sdebug rnd :: Rnd (FactionDict, FlavourMap, DiscoveryKind, DiscoveryKindRev, DungeonGen.FreshDungeon, Kind.Id ModeKind) rnd = do modeKindId <- fromMaybe (assert `failure` gameMode) <$> opick gameMode (const True) let mode = okind modeKindId automatePS ps = ps {rosterList = map (automatePlayer True) $ rosterList ps} players = if sautomateAll sdebug then automatePS $ mroster mode else mroster mode sflavour <- dungeonFlavourMap cops (sdiscoKind, sdiscoKindRev) <- serverDiscos cops freshDng <- DungeonGen.dungeonGen cops $ mcaves mode faction <- createFactions (DungeonGen.freshTotalDepth freshDng) players return (faction, sflavour, sdiscoKind, sdiscoKindRev, freshDng, modeKindId) let (faction, sflavour, sdiscoKind, sdiscoKindRev, DungeonGen.FreshDungeon{..}, modeKindId) = St.evalState rnd dungeonSeed defState = defStateGlobal freshDungeon freshTotalDepth faction cops scoreTable modeKindId defSer = emptyStateServer { sstart, sallTime, sheroNames, srandom , srngs = RNGs (Just dungeonSeed) (Just srandom) } putServer defSer when (sbenchmark $ sdebugCli sdebug) resetGameStart modifyServer $ \ser -> ser {sdiscoKind, sdiscoKindRev, 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 embedItemsInDungeon 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 -- Players that escape go first to be started over stairs, if possible. valuePlayer pl = (not $ fcanEscape pl, fname pl) -- Sorting, to keep games from similar game modes mutually reproducible. needInitialCrew = sortBy (comparing $ valuePlayer . gplayer . snd) $ filter ((> 0 ) . finitialActors . gplayer . snd) $ EM.assocs factionD getEntryLevel (_, fact) = max minD $ min maxD $ toEnum $ fentryLevel $ gplayer fact arenas = ES.toList $ ES.fromList $ map getEntryLevel needInitialCrew initialActors lid = do lvl <- getLevel lid let arenaFactions = filter ((== lid) . getEntryLevel) needInitialCrew indexff (fid, _) = findIndex ((== fid) . fst) arenaFactions representsAlliance ff2@(_, fact2) = not $ any (\ff3@(fid3, _) -> indexff ff3 < indexff ff2 && isAllied fact2 fid3) arenaFactions arenaAlliances = filter representsAlliance arenaFactions placeAlliance ((fid3, _), ppos, timeOffset) = mapM_ (\(fid4, fact4) -> when (isAllied fact4 fid3 || fid4 == fid3) $ placeActors lid ((fid4, fact4), ppos, timeOffset)) arenaFactions entryPoss <- rndToAction $ findEntryPoss cops lid lvl (length arenaAlliances) mapM_ placeAlliance $ zip3 arenaAlliances entryPoss [0..] placeActors lid ((fid3, fact3), ppos, timeOffset) = do time <- getsState $ getLocalTime lid let nmult = 1 + timeOffset `mod` 4 ntime = timeShift time (timeDeltaScale (Delta timeClip) nmult) validTile t = not $ Tile.hasFeature cotile TK.NoActor t psFree <- getsState $ nearbyFreePoints validTile ppos lid let ps = take (finitialActors $ gplayer fact3) $ zip [0..] psFree forM_ ps $ \ (n, p) -> do go <- if not $ fhasNumbers $ gplayer fact3 then recruitActors [p] lid ntime fid3 else do let hNames = EM.findWithDefault [] 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, Nothing)) 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 fact <- getsState $ (EM.! fid) . sfactionD let spawnName = fgroup $ gplayer fact laid <- forM ps $ \ p -> if fhasNumbers $ gplayer 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, Nothing)) 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) => GroupName ItemKind -> FactionId -> Point -> LevelId -> Time -> m (Maybe ActorId) addMonster groupName bfid ppos lid time = do fact <- getsState $ (EM.! bfid) . sfactionD pronoun <- if fhasGender $ gplayer 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 Faction{gcolor, gplayer} <- getsState $ (EM.! bfid) . sfactionD let groupName = fgroup gplayer mhs <- mapM (getsState . tryFindHeroK bfid) [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 (fname gplayer <+> nameN, pronounN) tweakBody b = b {bsymbol, bname, bcolor = gcolor} addActor groupName bfid ppos lid tweakBody pronoun time -- | Find starting postions for all factions. Try to make them distant -- from each other. Place as many of the initial factions, as possible, -- over stairs and escapes. findEntryPoss :: Kind.COps -> LevelId -> Level -> Int -> Rnd [Point] findEntryPoss Kind.COps{cotile} lid Level{ltile, lxsize, lysize, lstair, lescape} 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 TK.NoActor t)) [ dist ps $ factionDist `div` 2 , dist ps $ factionDist `div` 3 , const (Tile.hasFeature cotile TK.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 -- Prefer deeper stairs to avoid spawners ambushing explorers. (deeperStairs, shallowerStairs) = (if fromEnum lid > 0 then id else swap) lstair stairPoss = (deeperStairs \\ shallowerStairs) ++ lescape ++ shallowerStairs middlePos = Point (lxsize `div` 2) (lysize `div` 2) let !_A = assert (k > 0 && factionDist > 0) () onStairs = take k stairPoss nk = k - length onStairs found <- case nk of 0 -> return [] 1 -> tryFind onStairs nk 2 -> -- Make sure the first faction's pos is not chosen in the middle. tryFind (if null onStairs then [middlePos] else onStairs) nk _ -> tryFind onStairs nk return $! onStairs ++ found 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 }} LambdaHack-0.5.0.0/Game/LambdaHack/Server/HandleRequestServer.hs0000644000000000000000000005431412555256425022406 0ustar0000000000000000{-# 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, reqDisplace ) 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 qualified Game.LambdaHack.Common.Ability as Ability 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.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.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 qualified Game.LambdaHack.Content.ItemKind as IK import Game.LambdaHack.Content.ModeKind import qualified Game.LambdaHack.Content.TileKind as TK 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, m ()) handleRequestAI fid aid cmd = case cmd of ReqAITimed cmdT -> return (aid, handleRequestTimed aid cmdT) ReqAILeader aidNew mtgtNew cmd2 -> do switchLeader fid aidNew mtgtNew handleRequestAI fid aidNew cmd2 ReqAIPong -> return (aid, return ()) -- | 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, m ()) handleRequestUI fid cmd = case cmd of ReqUITimed cmdT -> do fact <- getsState $ (EM.! fid) . sfactionD let (aid, _) = fromMaybe (assert `failure` fact) $ gleader fact return (Just aid, handleRequestTimed aid cmdT) ReqUILeader aidNew mtgtNew cmd2 -> do switchLeader fid aidNew mtgtNew handleRequestUI fid cmd2 ReqUIGameRestart aid t d names -> return (Nothing, reqGameRestart aid t d names) ReqUIGameExit aid -> return (Nothing, reqGameExit aid) ReqUIGameSave -> return (Nothing, reqGameSave) ReqUITactic toT -> return (Nothing, reqTactic fid toT) ReqUIAutomate -> return (Nothing, reqAutomate fid) ReqUIPong _ -> return (Nothing, return ()) 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 ReqMoveItems l -> reqMoveItems aid l 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, MonadServer m) => FactionId -> ActorId -> Maybe Target -> m () switchLeader fid aidNew mtgtNew = do fact <- getsState $ (EM.! fid) . sfactionD bPre <- getsState $ getActorBody aidNew let mleader = gleader fact actorChanged = fmap fst mleader /= Just aidNew let !_A = assert (Just (aidNew, mtgtNew) /= mleader && not (bproj bPre) `blame` (aidNew, mtgtNew, bPre, fid, fact)) () let !_A = assert (bfid bPre == fid `blame` "client tries to move other faction actors" `twith` (aidNew, mtgtNew, bPre, fid, fact)) () let (autoDun, autoLvl) = autoDungeonLevel fact arena <- case mleader of Nothing -> return $! blid bPre Just (leader, _) -> do b <- getsState $ getActorBody leader return $! blid b if actorChanged && blid bPre /= arena && autoDun then execFailure aidNew ReqWait{-hack-} NoChangeDunLeader else if actorChanged && autoLvl then execFailure aidNew ReqWait{-hack-} NoChangeLvlLeader else execUpdAtomic $ UpdLeadFaction fid mleader (Just (aidNew, mtgtNew)) -- * 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. If smell already there and the actor can smell, remove smell. addSmell :: (MonadAtomic m, MonadServer m) => ActorId -> m () addSmell aid = do b <- getsState $ getActorBody aid fact <- getsState $ (EM.! bfid b) . sfactionD smellRadius <- sumOrganEqpServer IK.EqpSlotAddSmell aid let dumbMonster = not (fhasGender $ gplayer fact) && smellRadius <= 0 unless (bproj b || dumbMonster) $ do -- TODO: right now only humans leave smell and content should not -- give humans the ability to smell (dominated monsters are rare enough). -- In the future smells should be marked by the faction that left them -- and actors shold only follow enemy smells. time <- getsState $ getLocalTime $ blid b lvl <- getLevel $ blid b let oldS = EM.lookup (bpos b) . lsmell $ lvl newTime = timeShift time smellTimeout newS = if smellRadius > 0 then Nothing -- smelling monster or hero else Just newTime -- hero when (oldS /= newS) $ execUpdAtomic $ UpdAlterSmell (blid b) (bpos b) oldS newS -- | 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 $ posToActors tpos lid case tgt of (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 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 hitA | hurtBonus <= -50 -- e.g., braced and no hit bonus = HitBlock 2 | hurtBonus <= -10 -- low bonus vs armor = HitBlock 1 | otherwise = HitClear execSfxAtomic $ SfxStrike source target iid cstore 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)) let c = CActor source cstore -- Msgs inside itemEffect describe the target part. itemEffectAndDestroy source target iid c -- 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, etc. 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) [_] -> execUpdAtomic $ UpdDisplaceActor source target _ -> execFailure source req DisplaceProjectiles else -- 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 TK.Feature -> m () reqAlter source tpos mfeat = do cops@Kind.COps{cotile=cotile@Kind.Ops{okind, opick}} <- getsState scops sb <- getsState $ getActorBody source actorSk <- actorSkillsServer source let skill = EM.findWithDefault 0 Ability.AbAlter actorSk lid = blid sb spos = bpos sb req = ReqAlter tpos mfeat -- Only actors with AbAlter can search for hidden doors, etc. if skill < 1 then execFailure source req AlterUnskilled else if not $ adjacent spos tpos then execFailure source req AlterDistant else do lvl <- getLevel lid let serverTile = lvl `at` tpos freshClientTile = hideTile cops lvl tpos changeTo tgroup = do -- No @SfxAlter@, because the effect is obvious (e.g., opened door). toTile <- rndToAction $ 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 -> TK.tfeature $ okind serverTile Just feat2 | Tile.hasFeature cotile feat2 serverTile -> [feat2] Just _ -> [] toAlter feat = case feat of TK.OpenTo tgroup -> Just tgroup TK.CloseTo tgroup -> Just tgroup TK.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 if EM.notMember tpos $ lfloor lvl then if unoccupied as tpos then do when (serverTile /= freshClientTile) $ -- Search, in case some actors (of other factions?) -- don't know this tile. execUpdAtomic $ UpdSearchTile source tpos freshClientTile serverTile maybe (return ()) changeTo $ listToMaybe groupsToAlterTo -- TODO: pick another, if the first one void -- Perform an effect, if any permitted. void $ triggerEffect source tpos 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 () -- * ReqMoveItems reqMoveItems :: (MonadAtomic m, MonadServer m) => ActorId -> [(ItemId, Int, CStore, CStore)] -> m () reqMoveItems aid l = do b <- getsState $ getActorBody aid activeItems <- activeItemsServer aid -- 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 activeItems mapM_ (reqMoveItem aid calmE) l reqMoveItem :: (MonadAtomic m, MonadServer m) => ActorId -> Bool -> (ItemId, Int, CStore, CStore) -> m () reqMoveItem aid calmE (iid, k, fromCStore, toCStore) = do b <- getsState $ getActorBody aid let fromC = CActor aid fromCStore toC = CActor aid toCStore req = ReqMoveItems [(iid, k, fromCStore, toCStore)] bagBefore <- getsState $ getCBag toC 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) && not calmE then execFailure aid req ItemNotCalm else do when (fromCStore == CGround) $ do seed <- getsServer $ (EM.! iid) . sitemSeedD item <- getsState $ getItemBody iid Level{ldepth} <- getLevel $ jlid item execUpdAtomic $ UpdDiscoverSeed fromC iid seed ldepth upds <- generalMoveItem iid k fromC toC mapM_ execUpdAtomic upds -- Reset timeout for equipped periodic items. when (toCStore `elem` [CEqp, COrgan] && fromCStore `notElem` [CEqp, COrgan]) $ do localTime <- getsState $ getLocalTime (blid b) discoEffect <- getsServer sdiscoEffect -- The first recharging period after pick up is random, -- between 1 and 2 standard timeouts of the item. mrndTimeout <- rndToAction $ computeRndTimeout localTime discoEffect iid let beforeIt = case iid `EM.lookup` bagBefore of Nothing -> [] -- no such items before move Just (_, it2) -> it2 -- The moved item set (not the whole stack) has its timeout -- 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 $ getCBag toC let afterIt = case iid `EM.lookup` bagAfter of Nothing -> assert `failure` (iid, bagAfter, toC) Just (_, it2) -> it2 resetIt = beforeIt ++ replicate k rndT when (afterIt /= resetIt) $ execUpdAtomic $ UpdTimeItem iid toC afterIt resetIt Nothing -> return () -- no Periodic or Timeout aspect; don't touch computeRndTimeout :: Time -> DiscoveryEffect -> ItemId -> Rnd (Maybe Time) computeRndTimeout localTime discoEffect iid = do let timeoutAspect :: IK.Aspect Int -> Maybe Int timeoutAspect (IK.Timeout t) = Just t timeoutAspect _ = Nothing case EM.lookup iid discoEffect of Just ItemAspectEffect{jaspects} -> case mapMaybe timeoutAspect jaspects of [t] | IK.Periodic `elem` jaspects -> do rndT <- randomR (0, t) let rndTurns = timeDeltaScale (Delta timeTurn) rndT return $ Just $ timeShift localTime rndTurns _ -> return Nothing _ -> assert `failure` (iid, discoEffect) -- * 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 = do let req = ReqProject tpxy eps iid cstore b <- getsState $ getActorBody source activeItems <- activeItemsServer source let calmE = calmEnough b activeItems if cstore == CSha && not calmE then execFailure source req ItemNotCalm else do mfail <- projectFail source tpxy eps iid cstore False maybe (return ()) (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 = do let req = ReqApply iid cstore b <- getsState $ getActorBody aid activeItems <- activeItemsServer aid let calmE = calmEnough b activeItems if cstore == CSha && not calmE then execFailure aid req ItemNotCalm else do bag <- getsState $ getActorBag aid cstore case EM.lookup iid bag of Nothing -> execFailure aid req ApplyOutOfReach Just kit -> do itemToF <- itemToFullServer actorSk <- actorSkillsServer aid localTime <- getsState $ getLocalTime (blid b) let skill = EM.findWithDefault 0 Ability.AbApply actorSk itemFull = itemToF iid kit legal = permittedApply " " localTime skill itemFull b activeItems case legal of Left reqFail -> execFailure aid req reqFail Right _ -> applyItem aid iid cstore -- * ReqTrigger -- | Perform the effect specified for the tile in case it's triggered. reqTrigger :: (MonadAtomic m, MonadServer m) => ActorId -> Maybe TK.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 -> TK.tfeature $ okind serverTile Just feat2 | Tile.hasFeature cotile feat2 serverTile -> [feat2] Just _ -> [] req = ReqTrigger mfeat go <- triggerEffect aid tpos feats unless go $ execFailure aid req TriggerNothing triggerEffect :: (MonadAtomic m, MonadServer m) => ActorId -> Point -> [TK.Feature] -> m Bool triggerEffect aid tpos feats = do let triggerFeat feat = case feat of TK.Cause ef -> itemEffectCause aid tpos ef _ -> 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 -> GroupName ModeKind -> Int -> [(Int, (Text, Text))] -> m () reqGameRestart aid groupName d configHeroNames = do modifyServer $ \ser -> ser {sdebugNxt = (sdebugNxt ser) {scurDiffSer = 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) (Just groupName) -- * ReqGameExit reqGameExit :: (MonadAtomic m, MonadServer m) => ActorId -> m () reqGameExit aid = do b <- getsState $ getActorBody aid let fid = bfid b oldSt <- getsState $ gquit . (EM.! fid) . sfactionD modifyServer $ \ser -> ser {swriteSave = True} modifyServer $ \ser -> ser {squit = True} -- do this at once execUpdAtomic $ UpdQuitFaction fid (Just b) oldSt $ Just $ Status Camping (fromEnum $ blid b) Nothing -- * ReqGameSave reqGameSave :: MonadServer m => m () reqGameSave = do modifyServer $ \ser -> ser {swriteSave = True} modifyServer $ \ser -> ser {squit = True} -- do this at once -- * ReqTactic reqTactic :: (MonadAtomic m, MonadServer m) => FactionId -> Tactic -> m () reqTactic fid toT = do fromT <- getsState $ ftactic . gplayer . (EM.! fid) . sfactionD execUpdAtomic $ UpdTacticFaction fid toT fromT -- * ReqAutomate reqAutomate :: (MonadAtomic m, MonadServer m) => FactionId -> m () reqAutomate fid = execUpdAtomic $ UpdAutoFaction fid True LambdaHack-0.5.0.0/Game/LambdaHack/Server/DebugServer.hs0000644000000000000000000000643012555256425020664 0ustar0000000000000000-- | 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 qualified Text.Show.Pretty as Show.Pretty 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. debugShow :: Show a => a -> Text debugShow = T.pack . Show.Pretty.ppShow 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 serverPrint d RespPingAI -> serverPrint $ debugShow 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 serverPrint $ debugShow (cmd, ps) RespQueryUI -> serverPrint $ "RespQueryUI:" <+> debugShow cmd RespPingUI -> serverPrint $ debugShow cmd debugPretty :: (MonadServer m, Show a) => a -> UpdAtomic -> m () debugPretty cmd cmdA = do ps <- posUpdAtomic cmdA serverPrint $ debugShow (cmd, ps) debugPlain :: (MonadServer m, Show a) => a -> UpdAtomic -> m () debugPlain cmd cmdA = do ps <- posUpdAtomic cmdA serverPrint $ T.pack $ show (cmd, ps) -- too large for pretty printing debugRequestAI :: MonadServer m => ActorId -> RequestAI -> m () debugRequestAI aid cmd = do d <- debugAid aid "AI request" cmd serverPrint d debugRequestUI :: MonadServer m => ActorId -> RequestUI -> m () debugRequestUI aid cmd = do d <- debugAid aid "UI request" cmd serverPrint 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:" <+> debugShow label <+> debugShow cmd else do b <- getsState $ getActorBody aid time <- getsState $ getLocalTime (blid b) return $! debugShow DebugAid { label , cmd , lid = blid b , time , aid , faction = bfid b } LambdaHack-0.5.0.0/Game/LambdaHack/Server/PeriodicServer.hs0000644000000000000000000003646412555256425021406 0ustar0000000000000000-- | Server operations performed periodically in the game loop -- and related operations. module Game.LambdaHack.Server.PeriodicServer ( spawnMonster, addAnyActor, dominateFidSfx , advanceTime, swapTime, managePerTurn, leadLevelSwitch, udpateCalm ) where import Control.Exception.Assert.Sugar import Control.Monad import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES import Data.Int (Int64) 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 Game.LambdaHack.Common.Faction 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.Random import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile import Game.LambdaHack.Common.Time import Game.LambdaHack.Content.ItemKind (ItemKind) import qualified Game.LambdaHack.Content.ItemKind as IK import Game.LambdaHack.Content.ModeKind import qualified Game.LambdaHack.Content.TileKind as TK import Game.LambdaHack.Server.CommonServer 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 totalDepth <- getsState stotalDepth -- TODO: eliminate the defeated and victorious faction from lactorFreq; -- then fcanEscape and fneverEmpty make sense for spawning factions Level{ldepth, lactorCoeff, lactorFreq} <- getLevel lid lvlSpawned <- getsServer $ fromMaybe 0 . EM.lookup lid . snumSpawned rc <- rndToAction $ monsterGenChance ldepth totalDepth lvlSpawned lactorCoeff when rc $ do modifyServer $ \ser -> ser {snumSpawned = EM.insert lid (lvlSpawned + 1) $ snumSpawned ser} 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, Nothing)) addAnyActor :: (MonadAtomic m, MonadServer m) => Freqs ItemKind -> 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 lvl <- getLevel lid factionD <- getsState sfactionD lvlSpawned <- getsServer $ fromMaybe 0 . EM.lookup lid . snumSpawned m4 <- rollItem lvlSpawned lid actorFreq case m4 of Nothing -> return Nothing Just (itemKnown, trunkFull, itemDisco, seed, _) -> do let ik = itemKind itemDisco freqNames = map fst $ IK.ifreq ik f fact = fgroup (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) = fgroup (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 :( mobile = any (`elem` freqNames) ["mobile", "horror"] pos <- case mpos of Just pos -> return pos Nothing -> do fact <- getsState $ (EM.! fid) . sfactionD rollPos <- getsState $ rollSpawnPos cops allPers mobile lid lvl fact rndToAction rollPos let container = CTrunk fid lid pos trunkId <- registerItem trunkFull itemKnown seed (itemK trunkFull) container False addActorIid trunkId trunkFull False fid pos lid id "it" time rollSpawnPos :: Kind.COps -> ES.EnumSet Point -> Bool -> LevelId -> Level -> Faction -> State -> Rnd Point rollSpawnPos Kind.COps{cotile} visible mobile lid Level{ltile, lxsize, lysize} fact s = do let inhabitants = actorRegularList (isAtWar fact) lid s as = actorList (const True) lid s distantSo df p _ = all (\b -> df $ chessDist (bpos b) p) inhabitants middlePos = Point (lxsize `div` 2) (lysize `div` 2) distantMiddle d p _ = chessDist p middlePos < d condList | mobile = [ distantSo (<= 10) -- try hard to harass enemies , distantSo (<= 15) , distantSo (<= 20) ] | otherwise = [ distantMiddle 5 , distantMiddle 10 , distantMiddle 20 , distantMiddle 50 , distantMiddle 100 ] -- Not considering TK.OftenActor, because monsters emerge from hidden ducts, -- which are easier to hide in crampy corridors that lit halls. findPosTry (if mobile then 500 else 100) ltile ( \p t -> Tile.isWalkable cotile t && not (Tile.hasFeature cotile TK.NoActor t) && unoccupied as p) (condList ++ [ distantSo (> 5) -- otherwise actors in dark rooms are swarmed , distantSo (> 2) -- otherwise actors can be hit on entering level , \p _ -> not (p `ES.member` visible) -- surprise and believability ]) dominateFidSfx :: (MonadAtomic m, MonadServer m) => FactionId -> ActorId -> m Bool dominateFidSfx fid target = do tb <- getsState $ getActorBody target -- 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. activeItems <- activeItemsServer target let actorMaxSk = sumSkills activeItems canMove = EM.findWithDefault 0 Ability.AbMove actorMaxSk > 0 && EM.findWithDefault 0 Ability.AbTrigger actorMaxSk > 0 && EM.findWithDefault 0 Ability.AbAlter actorMaxSk > 0 if canMove && not (bproj tb) then do let execSfx = execSfxAtomic $ SfxEffect (bfidImpressed tb) target IK.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 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 target tb -- TODO: some messages after game over below? Compare with dieSer. ais <- getsState $ getCarriedAssocs tb calmMax <- sumOrganEqpServer IK.EqpSlotAddMaxCalm target execUpdAtomic $ UpdLoseActor target tb ais let bNew = tb { bfid = fid , bfidImpressed = bfid tb , bcalm = max 0 $ xM calmMax `div` 2 } execUpdAtomic $ UpdSpotActor target bNew ais let discoverSeed (iid, cstore) = do seed <- getsServer $ (EM.! iid) . sitemSeedD item <- getsState $ getItemBody iid Level{ldepth} <- getLevel $ jlid item let c = CActor target cstore execUpdAtomic $ UpdDiscoverSeed c iid seed ldepth aic = getCarriedIidCStore tb mapM_ discoverSeed aic 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, Nothing)) -- | Advance the move time for the given actor advanceTime :: (MonadAtomic m, MonadServer m) => ActorId -> m () advanceTime aid = do b <- getsState $ getActorBody aid activeItems <- activeItemsServer aid localTime <- getsState $ getLocalTime (blid b) let halfActorTurn = timeDeltaDiv (ticksPerMeter $ bspeed b activeItems) 2 -- Dead bodies stay around for only a half of standard turn, -- even if paralyzed. -- Projectiles that hit actors or are hit by actors vanish at once -- not to block actor's path, e.g., for Pull effect. t | bhp b <= 0 = let delta = Delta $ if bproj b then timeZero else timeTurn localPlusDelta = localTime `timeShift` delta in localPlusDelta `timeDeltaToFrom` btime b | otherwise = halfActorTurn execUpdAtomic $ UpdAgeActor aid t -- @t@ may be negative; that's OK -- | Swap the relative move times of two actors (e.g., when switching -- a UI leader). swapTime :: (MonadAtomic m, MonadServer 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) 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) $ execUpdAtomic $ UpdAgeActor source sdelta when (tdelta /= Delta timeZero) $ execUpdAtomic $ UpdAgeActor target tdelta -- | Check if the given actor is 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 causes a consistent Calm regeneration -- UI indicator to be displayed each turn (not every few turns). managePerTurn :: (MonadAtomic m, MonadServer m) => ActorId -> m () managePerTurn aid = do b <- getsState $ getActorBody aid unless (bproj b) $ do activeItems <- activeItemsServer aid fact <- getsState $ (EM.! bfid b) . sfactionD dominated <- -- We react one turn after bcalm reaches 0, to let it be -- displayed first, to let the player panic in advance -- and also to avoid the dramatic domination message -- be swamped in other enemy turn messages. if bcalm b == 0 && bfidImpressed b /= bfid b && fleaderMode (gplayer fact) /= LeaderNull -- animals/robots never Calm-dominated then dominateFidSfx (bfidImpressed 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. udpateCalm 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 udpateCalm :: (MonadAtomic m, MonadServer m) => ActorId -> Int64 -> m () udpateCalm target deltaCalm = do tb <- getsState $ getActorBody target activeItems <- activeItemsServer target let calmMax64 = xM $ sumSlotNoFilter IK.EqpSlotAddMaxCalm activeItems execUpdAtomic $ UpdRefillCalm target deltaCalm when (bcalm tb < calmMax64 && bcalm tb + deltaCalm >= calmMax64 && bfidImpressed tb /= bfidOriginal tb) $ execUpdAtomic $ UpdFidImpressedActor target (bfidImpressed tb) (bfidOriginal tb) leadLevelSwitch :: (MonadAtomic m, MonadServer m) => m () leadLevelSwitch = do Kind.COps{cotile} <- getsState scops let canSwitch fact = fst (autoDungeonLevel fact) -- a hack to help AI, until AI client can switch levels || case fleaderMode (gplayer fact) of LeaderNull -> False LeaderAI _ -> True LeaderUI _ -> False flipFaction fact | not $ canSwitch fact = return () flipFaction fact = 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) (gleader fact) (Just (a, Nothing)) factionD <- getsState sfactionD mapM_ flipFaction $ EM.elems factionD LambdaHack-0.5.0.0/Game/LambdaHack/Server/ProtocolServer.hs0000644000000000000000000002063112555256425021436 0ustar0000000000000000{-# LANGUAGE CPP #-} -- | 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 #ifdef EXPOSE_INTERNAL -- * Internal operations , ConnServerFaction #endif ) 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 Data.Maybe 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 cs = do -- We can't check in sfactionD, because client can be from an old game. when (isJust $ fst cs) $ 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 | fhasUI $ 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 (return ()) (forkUI fid) connUI liftIO $ mapWithKeyM_ forkClient toSpawn LambdaHack-0.5.0.0/Game/LambdaHack/Server/State.hs0000644000000000000000000002045612555256425017533 0ustar0000000000000000-- | Server and client game state types and operations. module Game.LambdaHack.Server.State ( StateServer(..), emptyStateServer , DebugModeSer(..), defDebugModeSer , RNGs(..), FovCache3(..), emptyFovCache3 ) where 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.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.Misc import Game.LambdaHack.Common.Perception import Game.LambdaHack.Common.Time import Game.LambdaHack.Content.ModeKind import Game.LambdaHack.Content.RuleKind import Game.LambdaHack.Server.ItemRev -- | Global, server state. data StateServer = StateServer { sdiscoKind :: !DiscoveryKind -- ^ full item kind discoveries data , sdiscoKindRev :: !DiscoveryKindRev -- ^ reverse map, used for item creation , suniqueSet :: !UniqueSet -- ^ already generated unique items , sdiscoEffect :: !DiscoveryEffect -- ^ full item effect&Co data , sitemSeedD :: !ItemSeedDict -- ^ map from item ids to item seeds , sitemRev :: !ItemRev -- ^ reverse id map, used for item creation , sItemFovCache :: !(EM.EnumMap ItemId FovCache3) -- ^ (sight, smell, light) aspect bonus -- of the item; zeroes if not in the map , sflavour :: !FlavourMap -- ^ association of flavour to items , sacounter :: !ActorId -- ^ stores next actor index , sicounter :: !ItemId -- ^ stores next item index , snumSpawned :: !(EM.EnumMap LevelId Int) , 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 , swriteSave :: !Bool -- ^ write savegame to a file 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) data FovCache3 = FovCache3 { fovSight :: !Int , fovSmell :: !Int , fovLight :: !Int } deriving (Show, Eq) emptyFovCache3 :: FovCache3 emptyFovCache3 = FovCache3 0 0 0 -- | Debug commands. See 'Server.debugArgs' for the descriptions. data DebugModeSer = DebugModeSer { sknowMap :: !Bool , sknowEvents :: !Bool , sniffIn :: !Bool , sniffOut :: !Bool , sallClear :: !Bool , sgameMode :: !(Maybe (GroupName ModeKind)) , sautomateAll :: !Bool , skeepAutomated :: !Bool , sstopAfter :: !(Maybe Int) , sdungeonRng :: !(Maybe R.StdGen) , smainRng :: !(Maybe R.StdGen) , sfovMode :: !(Maybe FovMode) , snewGameSer :: !Bool , scurDiffSer :: !Int , sdumpInitRngs :: !Bool , ssavePrefixSer :: !(Maybe String) , sdbgMsgSer :: !Bool , sdebugCli :: !DebugModeCli -- ^ client debug parameters } 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 unwords args -- | Initial, empty game server state. emptyStateServer :: StateServer emptyStateServer = StateServer { sdiscoKind = EM.empty , sdiscoKindRev = EM.empty , suniqueSet = ES.empty , sdiscoEffect = EM.empty , sitemSeedD = EM.empty , sitemRev = HM.empty , sItemFovCache = EM.empty , sflavour = emptyFlavourMap , sacounter = toEnum 0 , sicounter = toEnum 0 , snumSpawned = EM.empty , sprocessed = EM.empty , sundo = [] , sper = EM.empty , srandom = R.mkStdGen 42 , srngs = RNGs { dungeonRandomGenerator = Nothing , startingRandomGenerator = Nothing } , squit = False , swriteSave = 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 = Nothing , sautomateAll = False , skeepAutomated = False , sstopAfter = Nothing , sdungeonRng = Nothing , smainRng = Nothing , sfovMode = Nothing , snewGameSer = False , scurDiffSer = difficultyDefault , sdumpInitRngs = False , ssavePrefixSer = Nothing , sdbgMsgSer = False , sdebugCli = defDebugModeCli } instance Binary StateServer where put StateServer{..} = do put sdiscoKind put sdiscoKindRev put suniqueSet put sdiscoEffect put sitemSeedD put sitemRev put sItemFovCache -- out of laziness, but it's small put sflavour put sacounter put sicounter put snumSpawned put sprocessed put sundo put (show srandom) put srngs put sheroNames put sdebugSer get = do sdiscoKind <- get sdiscoKindRev <- get suniqueSet <- get sdiscoEffect <- get sitemSeedD <- get sitemRev <- get sItemFovCache <- get sflavour <- get sacounter <- get sicounter <- get snumSpawned <- get sprocessed <- get sundo <- get g <- get srngs <- get sheroNames <- get sdebugSer <- get let srandom = read g sper = EM.empty squit = False swriteSave = 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 FovCache3 where put FovCache3{..} = do put fovSight put fovSmell put fovLight get = do fovSight <- get fovSmell <- get fovLight <- get return $! FovCache3{..} instance Binary DebugModeSer where put DebugModeSer{..} = do put sknowMap put sknowEvents put sniffIn put sniffOut put sallClear put sgameMode put sautomateAll put skeepAutomated put scurDiffSer put sfovMode put ssavePrefixSer put sdbgMsgSer put sdebugCli get = do sknowMap <- get sknowEvents <- get sniffIn <- get sniffOut <- get sallClear <- get sgameMode <- get sautomateAll <- get skeepAutomated <- get scurDiffSer <- get sfovMode <- get ssavePrefixSer <- get sdbgMsgSer <- get sdebugCli <- get let sstopAfter = Nothing 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{..} LambdaHack-0.5.0.0/Game/LambdaHack/Server/LoopServer.hs0000644000000000000000000004664112555256425020557 0ustar0000000000000000{-# 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.Applicative 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 Game.LambdaHack.Common.ClientOptions import qualified Game.LambdaHack.Common.Color as Color 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.Random import Game.LambdaHack.Common.Request import Game.LambdaHack.Common.Response import Game.LambdaHack.Common.State import Game.LambdaHack.Common.Time import Game.LambdaHack.Common.Vector import qualified Game.LambdaHack.Content.ItemKind as IK 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.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, including the clients, and then loop, -- communicating with the clients. loopSer :: (MonadAtomic m, MonadServerReadRequest m) => Kind.COps -- ^ game content -> DebugModeSer -- ^ server debug parameters -> (FactionId -> ChanServer ResponseUI RequestUI -> IO ()) -- ^ the code to run for UI clients -> (FactionId -> ChanServer ResponseAI RequestAI -> IO ()) -- ^ the code to run for AI clients -> m () loopSer cops sdebug executorUI executorAI = 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 Nothing 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 writeSaveAll False resetSessionStart -- Note that if a faction enters dungeon on a level with no spawners, -- the faction won't cause spawning on its active arena -- as long as it has no leader. This may cause regeneration items -- of its opponents become overpowered and lead to micromanagement -- (make sure to kill all actors of the faction, go to a no-spawn -- level and heal fully with no risk nor cost). let arenasForLoop = do let 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 -> if fleaderMode (gplayer fact) == LeaderNull || EM.null (gvictims fact) then return Nothing else Just <$> getEntryArena fact factionD <- getsState sfactionD marenas <- mapM factionArena $ EM.elems factionD let arenas = ES.toList $ ES.fromList $ catMaybes marenas let !_A = assert (not $ null arenas) () -- game over not caught earlier return $! arenas -- 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 arenasStart [] = do arenas <- arenasForLoop continue <- endClip arenasStart when continue (loop arenas arenas) loop arenasStart (arena : rest) = do handleActors arena 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} let loopAgain = loop arenasStart (arena : rest) endOrLoop loopAgain (restartGame updConn loopNew) gameExit (writeSaveAll True) else loop arenasStart rest loopNew = do arenas <- arenasForLoop loop arenas arenas loopNew endClip :: (MonadAtomic m, MonadServer m, MonadServerReadRequest m) => [LevelId] -> m Bool endClip arenas = do Kind.COps{corule} <- getsState scops let stdRuleset = Kind.stdRuleset corule writeSaveClips = rwriteSaveClips stdRuleset leadLevelClips = rleadLevelClips stdRuleset ageProcessed lid = EM.insertWith absoluteTimeAdd lid timeClip 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` writeSaveClips == 0) $ do modifyServer $ \ser -> ser {swriteSave = False} writeSaveAll False when (clipN `mod` leadLevelClips == 0) leadLevelSwitch if clipMod == 1 then do -- Periodic activation only once per turn, for speed, but on all arenas. mapM_ applyPeriodicLevel arenas -- 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. arena <- rndToAction $ oneOf arenas spawnMonster arena -- Check, once per turn, for benchmark game stop, after a set time. 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. applyPeriodicLevel :: (MonadAtomic m, MonadServer m) => LevelId -> m () applyPeriodicLevel lid = do discoEffect <- getsServer sdiscoEffect let applyPeriodicItem c aid iid = case EM.lookup iid discoEffect of Just ItemAspectEffect{jeffects, jaspects} -> when (IK.Periodic `elem` jaspects) $ do -- Check if the item is still in the bag (previous items act!). bag <- getsState $ getCBag c case iid `EM.lookup` bag of Nothing -> return () -- item dropped Just kit -> -- In periodic activation, consider *only* recharging effects. effectAndDestroy aid aid iid c True (allRecharging jeffects) jaspects kit _ -> assert `failure` (lid, aid, c, iid) applyPeriodicCStore aid cstore = do let c = CActor aid cstore bag <- getsState $ getCBag c mapM_ (applyPeriodicItem c aid) $ EM.keys bag applyPeriodicActor aid = do applyPeriodicCStore aid COrgan applyPeriodicCStore aid CEqp allActors <- getsState $ actorRegularAssocs (const True) lid mapM_ (\(aid, _) -> applyPeriodicActor 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. notDead (_, b) = not $ actorDying b notProj (_, b) = not $ bproj b notLeader (aid, b) = Just aid /= fmap fst (gleader (factionD EM.! bfid b)) order = Ord.comparing $ notDead &&& notProj &&& bfid . snd &&& notLeader &&& 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) | bproj b && maybe True (null . fst) (btrajectory b) -> do startActor aid -- A projectile drops to the ground due to obstacles or range. -- The carried item is not destroyed, but drops to the ground. dieSer aid b False handleActors lid Just (aid, b) | bhp b <= 0 -> do startActor aid -- If @b@ is a projectile and it hits an actor, -- the carried item is destroyed and that's all. -- Otherwise, an actor dies, items drop to the ground -- and possibly a new leader is elected. dieSer aid b (bproj b) handleActors lid Just (aid, body) -> do let side = bfid body fact = factionD EM.! side mleader = gleader fact aidIsLeader = fmap fst mleader == Just aid mainUIactor = fhasUI (gplayer fact) && (aidIsLeader || fleaderMode (gplayer fact) == LeaderNull) queryUI <- if mainUIactor then do let underAI = isAIFact 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 = isAIFact 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 setTrajectory aid b2 <- getsState $ getActorBody aid unless (bproj b2 && actorDying b2) $ 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, action) <- handleRequestUI side cmdS let hasWait (ReqUITimed ReqWait{}) = True hasWait (ReqUILeader _ _ cmd) = hasWait cmd hasWait _ = False maybe (return ()) (setBWait (hasWait cmdS)) aidNew -- Advance time once, after the leader switched perhaps many times. -- The following was true before, but now we badly want to avoid double -- moves against the UI player (especially deadly when using stairs), -- so this is no longer true: -- Sometimes this may result in a double move of the new leader, -- followed by a double pause. Or a fractional variant of that. -- In this setup, reading a scroll of Previous Leader is a free action -- for the old leader, but otherwise his time is undisturbed. -- He is able to move normally in the same turn, immediately -- after the new leader completes his move. -- So now 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, but at least the sum of times is OK. -- 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. when (aidIsLeader && Just aid /= aidNew) $ maybe (return ()) (swapTime aid) aidNew maybe (return ()) advanceTime aidNew action maybe (return ()) managePerTurn 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. when mainUIactor $ execUpdAtomic $ UpdRecordHistory side cmdS <- sendQueryAI side aid (aidNew, action) <- 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 action managePerTurn aidNew b3 <- getsState $ getActorBody aid unless (waitedLastTurn b3) $ startActor aid 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 let !_A = assert (persAccumulated == pers `blame` "wrong accumulated perception" `twith` (persAccumulated, pers)) () return () restartGame :: (MonadAtomic m, MonadServerReadRequest m) => m () -> m () -> Maybe (GroupName ModeKind) -> m () restartGame updConn loop mgameMode = do tellGameClipPS cops <- getsState scops sdebugNxt <- getsServer sdebugNxt srandom <- getsServer srandom s <- gameReset cops sdebugNxt mgameMode (Just srandom) let debugBarRngs = sdebugNxt {sdungeonRng = Nothing, smainRng = Nothing} modifyServer $ \ser -> ser { sdebugNxt = debugBarRngs , sdebugSer = debugBarRngs } execUpdAtomic $ UpdRestartServer s updConn initPer reinitGame writeSaveAll 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. writeSaveAll :: (MonadAtomic m, MonadServerReadRequest m) => Bool -> m () writeSaveAll uiRequested = do bench <- getsServer $ sbenchmark . sdebugCli . sdebugSer when (uiRequested || not bench) $ do factionD <- getsState sfactionD let ping fid _ = do sendPingAI fid when (fhasUI $ gplayer $ factionD EM.! fid) $ sendPingUI fid mapWithKeyM_ ping factionD execUpdAtomic UpdWriteSave 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 () setTrajectory aid = do cops <- getsState scops b <- getsState $ getActorBody aid lvl <- getLevel $ blid b case btrajectory b of Just (d : lv, speed) -> if not $ accessibleDir cops lvl (bpos b) d then do -- Lose HP due to bumping into an obstacle. execUpdAtomic $ UpdRefillHP aid minusM execUpdAtomic $ UpdTrajectory aid (btrajectory b) (Just ([], speed)) else do when (bproj b && null lv) $ do let toColor = Color.BrBlack when (bcolor b /= toColor) $ execUpdAtomic $ UpdColorActor aid (bcolor b) toColor -- Hit clears trajectory of non-projectiles in reqMelee so no need here. -- Non-projectiles displace, to make pushing in crowds less lethal -- and chaotic and to avoid hitting harpoons when pulled by them. let tpos = bpos b `shift` d -- target position tgt <- getsState $ posToActors tpos (blid b) case tgt of [(target, _)] | not (bproj b) -> reqDisplace aid target _ -> reqMove aid d b2 <- getsState $ getActorBody aid unless (btrajectory b2 == Just (lv, speed)) $ -- cleared in reqMelee execUpdAtomic $ UpdTrajectory aid (btrajectory b2) (Just (lv, speed)) Just ([], _) -> do -- non-projectile actor stops flying let !_A = assert (not $ bproj b) () execUpdAtomic $ UpdTrajectory aid (btrajectory b) Nothing _ -> assert `failure` "Nothing trajectory" `twith` (aid, b) LambdaHack-0.5.0.0/Game/LambdaHack/Server/DungeonGen.hs0000644000000000000000000003065612555256425020507 0ustar0000000000000000{-# LANGUAGE CPP #-} -- | The unpopulated dungeon generation routine. module Game.LambdaHack.Server.DungeonGen ( FreshDungeon(..), dungeonGen #ifdef EXPOSE_INTERNAL -- * Internal operations , convertTileMaps, placeStairs, buildLevel, levelFromCaveKind, findGenerator #endif ) where import Control.Applicative 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 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.ItemKind (ItemKind) import qualified Game.LambdaHack.Content.ItemKind as IK import Game.LambdaHack.Content.ModeKind import Game.LambdaHack.Content.TileKind (TileKind) import qualified Game.LambdaHack.Content.TileKind as TK import Game.LambdaHack.Server.DungeonGen.Area import Game.LambdaHack.Server.DungeonGen.Cave import Game.LambdaHack.Server.DungeonGen.Place convertTileMaps :: Kind.COps -> Rnd (Kind.Id TileKind) -> Maybe (Rnd (Kind.Id TileKind)) -> Int -> Int -> TileMapEM -> Rnd TileMap convertTileMaps Kind.COps{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.COps -> TileMap -> CaveKind -> [Point] -> Rnd Point placeStairs Kind.COps{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 TK.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 TK.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=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 = Tile.kindHasFeature (TK.Cause $ IK.Escape p) ascendable = Tile.kindHasFeature $ TK.Cause (IK.Ascend 1) descendable = Tile.kindHasFeature $ TK.Cause (IK.Ascend (-1)) nightCond kt = not (Tile.kindHasFeature TK.Clear kt) || (if dnight then id else not) (Tile.kindHasFeature TK.Dark kt) dcond kt = (cpassable || not (Tile.kindHasFeature TK.Walkable kt)) && nightCond kt pickDefTile = fromMaybe (assert `failure` cdefTile) <$> opick cdefTile dcond wcond kt = Tile.kindHasFeature TK.Walkable kt && nightCond kt mpickWalkable = if cpassable then Just $ fromMaybe (assert `failure` cdefTile) <$> opick cdefTile wcond else Nothing cmap <- convertTileMaps cops 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) && (not noAsc || not (ascendable tk)) && (not noDesc || not (descendable tk)) stairsCur = up ++ down ++ upDown posCur = nub $ sort $ map fst stairsCur spos <- placeStairs cops cmap kc posCur let legend = findLegend spos stairId <- 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) ([], [], []) let !_A = assert (null stairsUp1) () 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 null (stairsUp2 ++ stairsDown2) then makeStairs False True (ln == minD) (stairsUp2, stairsDown2, stairsUpDown2) else return (stairsUp2, stairsDown2, stairsUpDown2) let stairsUpAndUpDown = stairsUp ++ stairsUpDown let !_A = assert (length stairsUpAndUpDown == nstairUp) () let stairsTotal = stairsUpAndUpDown ++ stairsDown posTotal = nub $ sort $ map fst stairsTotal epos <- placeStairs cops 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 cactorCoeff cactorFreq litemNum citemFreq lsecret (map fst escape) -- | Build rudimentary level from a cave kind. levelFromCaveKind :: Kind.COps -> CaveKind -> AbsDepth -> TileMap -> ([Point], [Point]) -> Int -> Freqs ItemKind -> Int -> Freqs ItemKind -> Int -> [Point] -> Level levelFromCaveKind Kind.COps{cotile} CaveKind{..} ldepth ltile lstair lactorCoeff lactorFreq litemNum litemFreq lsecret lescape = let lvl = Level { ldepth , lprio = EM.empty , lfloor = EM.empty , lembed = EM.empty -- is populated inside $MonadServer$ , ltile , lxsize = cxsize , lysize = cysize , lsmell = EM.empty , ldesc = cname , lstair , lseen = 0 , lclear = 0 -- calculated below , ltime = timeZero , lactorCoeff , 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 -> (GroupName CaveKind, Maybe Bool) -> Rnd Level findGenerator cops ln minD maxD totalDepth nstairUp (genName, escapeFeature) = do let Kind.COps{cocave=Kind.Ops{opick}} = cops ci <- 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, (GroupName CaveKind, 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 let !_A = assert (nstairUpLast == 0) () let freshDungeon = EM.fromList levels return $! FreshDungeon{..} LambdaHack-0.5.0.0/Game/LambdaHack/Server/HandleEffectServer.hs0000644000000000000000000013320012555256425022142 0ustar0000000000000000{-# LANGUAGE TupleSections #-} -- | Handle effects (most often caused by requests sent by clients). module Game.LambdaHack.Server.HandleEffectServer ( applyItem, itemEffectAndDestroy, effectAndDestroy, itemEffectCause , dropCStoreItem, armorHurtBonus ) where import Control.Applicative import Control.Exception.Assert.Sugar import Control.Monad import Data.Bits (xor) import qualified Data.EnumMap.Strict as EM import qualified Data.HashMap.Strict as HM import Data.Key (mapWithKeyM_) import Data.List import Data.Maybe 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 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.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 (ItemKind) import qualified Game.LambdaHack.Content.ItemKind as IK import Game.LambdaHack.Content.ModeKind import qualified Game.LambdaHack.Content.TileKind as TK 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 execSfxAtomic $ SfxApply aid iid cstore let c = CActor aid cstore itemEffectAndDestroy aid aid iid c itemEffectAndDestroy :: (MonadAtomic m, MonadServer m) => ActorId -> ActorId -> ItemId -> Container -> m () itemEffectAndDestroy source target iid c = do discoEffect <- getsServer sdiscoEffect case EM.lookup iid discoEffect of Just ItemAspectEffect{jeffects, jaspects} -> do bag <- getsState $ getCBag c case iid `EM.lookup` bag of Nothing -> assert `failure` (source, target, iid, c) Just kit -> effectAndDestroy source target iid c False jeffects jaspects kit _ -> assert `failure` (source, target, iid, c) effectAndDestroy :: (MonadAtomic m, MonadServer m) => ActorId -> ActorId -> ItemId -> Container -> Bool -> [IK.Effect] -> [IK.Aspect Int] -> ItemQuant -> m () effectAndDestroy source target iid c periodic effs aspects kitK@(k, it) = do let mtimeout = let timeoutAspect :: IK.Aspect a -> Bool timeoutAspect IK.Timeout{} = True timeoutAspect _ = False in find timeoutAspect aspects lid <- getsState $ lidFromC c localTime <- getsState $ getLocalTime lid let it1 = case mtimeout of Just (IK.Timeout timeout) -> let timeoutTurns = timeDeltaScale (Delta timeTurn) timeout charging startT = timeShift startT timeoutTurns > localTime in filter charging it _ -> [] len = length it1 recharged = len < k let !_A = assert (len <= k `blame` (kitK, source, target, iid, c)) () -- If there is no Timeout, but there are Recharging, -- then such effects are disabled whenever the item is affected -- by a Discharge attack (TODO). it2 <- case mtimeout of Just (IK.Timeout _) | recharged -> return $ localTime : it1 _ -> -- TODO: if has timeout and not recharged, report failure return it1 -- 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. it3 <- if it /= it2 && mtimeout /= Just (IK.Timeout 0) then do execUpdAtomic $ UpdTimeItem iid c it it2 return it2 else return it -- If the activation is not periodic, trigger at least the effects -- that are not recharging and so don't depend on @recharged@. when (not periodic || recharged) $ 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 mtmp = let tmpEffect :: IK.Effect -> Bool tmpEffect IK.Temporary{} = True tmpEffect (IK.Recharging IK.Temporary{}) = True tmpEffect (IK.OnSmash IK.Temporary{}) = True tmpEffect _ = False in find tmpEffect effs item <- getsState $ getItemBody iid let durable = IK.Durable `elem` jfeature item imperishable = durable || periodic && isNothing mtmp kit = if isNothing mtmp || periodic then (1, take 1 it3) else (k, it3) unless imperishable $ execUpdAtomic $ UpdLoseItem iid item kit c -- At this point, the item is potentially no longer in container @c@, -- so we don't pass @c@ along. triggered <- itemEffectDisco source target iid c recharged periodic effs -- 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). unless (triggered || imperishable) $ execUpdAtomic $ UpdSpotItem iid item kit c itemEffectCause :: (MonadAtomic m, MonadServer m) => ActorId -> Point -> IK.Effect -> m Bool itemEffectCause aid tpos ef = do sb <- getsState $ getActorBody aid let c = CEmbed (blid sb) tpos bag <- getsState $ getCBag c case EM.assocs bag of [(iid, kit)] -> do -- No block against tile, hence unconditional. discoEffect <- getsServer sdiscoEffect let aspects = case EM.lookup iid discoEffect of Just ItemAspectEffect{jaspects} -> jaspects _ -> assert `failure` (aid, tpos, ef, iid) execSfxAtomic $ SfxTrigger aid tpos $ TK.Cause ef effectAndDestroy aid aid iid c False [ef] aspects kit return True ab -> assert `failure` (aid, tpos, ab) -- | The source actor affects the target actor, with a given item. -- If any of the effects fires up, the item gets identified. This function -- is mutually recursive with @effect@ and so it's a part of @Effect@ -- semantics. itemEffectDisco :: (MonadAtomic m, MonadServer m) => ActorId -> ActorId -> ItemId -> Container -> Bool -> Bool -> [IK.Effect] -> m Bool itemEffectDisco source target iid c recharged periodic effs = do discoKind <- getsServer sdiscoKind item <- getsState $ getItemBody iid case EM.lookup (jkindIx item) discoKind of Just itemKindId -> do seed <- getsServer $ (EM.! iid) . sitemSeedD Level{ldepth} <- getLevel $ jlid item -- TODO: we leak first depth the item was created at on the server execUpdAtomic $ UpdDiscover c iid itemKindId seed ldepth itemEffect source target iid recharged periodic effs _ -> assert `failure` (source, target, iid, item) itemEffect :: (MonadAtomic m, MonadServer m) => ActorId -> ActorId -> ItemId -> Bool -> Bool -> [IK.Effect] -> m Bool itemEffect source target iid recharged periodic effects = do trs <- mapM (effectSem source target iid recharged) 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 || periodic -- don't spam from fizzled periodic effects || bproj sb) $ -- don't spam, projectiles can be very numerous if null effects then execSfxAtomic $ SfxMsgFid (bfid sb) "Nothing happens." else execSfxAtomic $ SfxMsgFid (bfid sb) "It flashes and fizzles." 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 item may or may not still be in the container. -- The boolean result indicates if the effect actually fired up, -- as opposed to fizzled. effectSem :: (MonadAtomic m, MonadServer m) => ActorId -> ActorId -> ItemId -> Bool -> IK.Effect -> m Bool effectSem source target iid recharged effect = do let recursiveCall = effectSem source target iid recharged 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 IK.NoEffect _ -> return False IK.Hurt nDm -> effectHurt nDm source target IK.RefillHP IK.Burn nDm -> effectBurn nDm source target IK.Explode t -> effectExplode execSfx t target IK.RefillHP p -> effectRefillHP False execSfx p source target IK.OverfillHP p -> effectRefillHP True execSfx p source target IK.RefillCalm p -> effectRefillCalm False execSfx p source target IK.OverfillCalm p -> effectRefillCalm True execSfx p source target IK.Dominate -> effectDominate recursiveCall source target IK.Impress -> effectImpress source target IK.CallFriend p -> effectCallFriend execSfx p source target IK.Summon freqs p -> effectSummon execSfx freqs p source target IK.Ascend p -> effectAscend recursiveCall execSfx p source target IK.Escape{} -> effectEscape source target IK.Paralyze p -> effectParalyze execSfx p target IK.InsertMove p -> effectInsertMove execSfx p target IK.Teleport p -> effectTeleport execSfx p source target IK.CreateItem store grp tim -> effectCreateItem target store grp tim IK.DropItem store grp hit -> effectDropItem execSfx store grp hit target IK.PolyItem -> effectPolyItem execSfx source target IK.Identify -> effectIdentify execSfx iid source target IK.SendFlying tmod -> effectSendFlying execSfx tmod source target Nothing IK.PushActor tmod -> effectSendFlying execSfx tmod source target (Just True) IK.PullActor tmod -> effectSendFlying execSfx tmod source target (Just False) IK.DropBestWeapon -> effectDropBestWeapon execSfx target IK.ActivateInv symbol -> effectActivateInv execSfx target symbol IK.ApplyPerfume -> effectApplyPerfume execSfx target IK.OneOf l -> effectOneOf recursiveCall l IK.OnSmash _ -> return False -- ignored under normal circumstances IK.Recharging e -> effectRecharging recursiveCall e recharged IK.Temporary _ -> effectTemporary execSfx source iid -- + Individual semantic functions for effects -- ** Hurt -- Modified by armor. Can, exceptionally, add HP. effectHurt :: (MonadAtomic m, MonadServer m) => Dice.Dice -> ActorId -> ActorId -> (Int -> IK.Effect) -> m Bool effectHurt nDm source target verboseEffectConstructor = do sb <- getsState $ getActorBody source tb <- getsState $ getActorBody target hpMax <- sumOrganEqpServer IK.EqpSlotAddMaxHP target n <- rndToAction $ castDice (AbsDepth 0) (AbsDepth 0) nDm hurtBonus <- armorHurtBonus source target let mult = 100 + hurtBonus rawDeltaHP = - (max oneM -- at least 1 HP taken (fromIntegral mult * xM n `divUp` 100)) serious = source /= target && not (bproj tb) deltaHP | serious = -- if HP overfull, at least cut back to max HP min rawDeltaHP (xM hpMax - bhp tb) | otherwise = rawDeltaHP deltaDiv = fromIntegral $ deltaHP `divUp` oneM -- Damage the target. execUpdAtomic $ UpdRefillHP target deltaHP when serious $ halveCalm target execSfxAtomic $ SfxEffect (bfid sb) target $ if source == target then verboseEffectConstructor deltaDiv -- no SfxStrike, so treat as any heal/wound else IK.Hurt (Dice.intToDice (- deltaDiv)) -- SfxStrike already sent, avoid spam 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 tb <- getsState $ getActorBody target let itemBonus = if bproj sb then sumSlotNoFilter IK.EqpSlotAddHurtRanged sactiveItems - sumSlotNoFilter IK.EqpSlotAddArmorRanged tactiveItems else sumSlotNoFilter IK.EqpSlotAddHurtMelee sactiveItems - sumSlotNoFilter IK.EqpSlotAddArmorMelee tactiveItems block = braced tb return $! itemBonus - if block then 50 else 0 halveCalm :: (MonadAtomic m, MonadServer m) => ActorId -> m () halveCalm target = do tb <- getsState $ getActorBody target activeItems <- activeItemsServer target let calmMax = sumSlotNoFilter IK.EqpSlotAddMaxCalm activeItems upperBound = if hpTooLow tb activeItems then 0 -- to trigger domination, etc. else max (xM calmMax) (bcalm tb) `div` 2 deltaCalm = min minusTwoM (upperBound - 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@. udpateCalm target deltaCalm -- ** Burn -- Damage from both impact and fire. Modified by armor. effectBurn :: (MonadAtomic m, MonadServer m) => Dice.Dice -> ActorId -> ActorId -> m Bool effectBurn nDm source target = effectHurt nDm source target (\p -> IK.Burn $ Dice.intToDice (-p)) -- ** Explode effectExplode :: (MonadAtomic m, MonadServer m) => m () -> GroupName ItemKind -> 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 Nothing 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 | itemK >= 8 && n < 8 = 0 | n < 8 && n >= 4 = 4 | otherwise = n psAll = [ 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 ] -- Keep full symmetry, but only if enough projectiles. Fall back -- to random, on average, symmetry. ps = take k $ if k >= 4 then psAll else drop ((n + x + y + fromEnum iid * 7) `mod` 16) $ cycle $ psAll ++ reverse psAll 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 blasts 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 (return ()) (projectN k100) mn2 bag3 <- getsState $ beqp . getActorBody target let mn3 = EM.lookup iid bag3 maybe (return ()) (\kit -> execUpdAtomic $ UpdLoseItem iid itemBase kit container) mn3 execSfx return True -- we neglect verifying that at least one projectile got off -- ** RefillHP -- Unaffected by armor. effectRefillHP :: (MonadAtomic m, MonadServer m) => Bool -> m () -> Int -> ActorId -> ActorId -> m Bool effectRefillHP overfill execSfx power source target = do tb <- getsState $ getActorBody target hpMax <- sumOrganEqpServer IK.EqpSlotAddMaxHP target let overMax | overfill = xM hpMax * 10 -- arbitrary limit to scumming | otherwise = xM hpMax serious = not (bproj tb) && source /= target && power > 1 deltaHP | power > 0 = min (xM power) (max 0 $ overMax - bhp tb) | serious = -- if overfull, at least cut back to max min (xM power) (xM hpMax - bhp tb) | otherwise = xM power if deltaHP == 0 then return False else do execUpdAtomic $ UpdRefillHP target deltaHP execSfx when (deltaHP < 0 && serious) $ halveCalm target return True -- ** RefillCalm effectRefillCalm :: (MonadAtomic m, MonadServer m) => Bool -> m () -> Int -> ActorId -> ActorId -> m Bool effectRefillCalm overfill execSfx power source target = do tb <- getsState $ getActorBody target calmMax <- sumOrganEqpServer IK.EqpSlotAddMaxCalm target let overMax | overfill = xM calmMax * 10 -- arbitrary limit to scumming | otherwise = xM calmMax serious = not (bproj tb) && source /= target && power > 1 deltaCalm | power > 0 = min (xM power) (max 0 $ overMax - bcalm tb) | serious = -- if overfull, at least cut back to max min (xM power) (xM calmMax - bcalm tb) | otherwise = xM power if deltaCalm == 0 then return False else do execSfx udpateCalm target deltaCalm return True -- ** Dominate effectDominate :: (MonadAtomic m, MonadServer m) => (IK.Effect -> m Bool) -> ActorId -> ActorId -> m Bool effectDominate recursiveCall source target = do sb <- getsState $ getActorBody source tb <- getsState $ getActorBody target if bfid tb == bfid sb then -- Dominate is rather on projectiles than on items, so alternate effect -- is useful to avoid boredom if domination can't happen. recursiveCall IK.Impress else dominateFidSfx (bfid sb) target -- ** Impress effectImpress :: (MonadAtomic m, MonadServer m) => ActorId -> ActorId -> m Bool effectImpress source target = do sb <- getsState $ getActorBody source tb <- getsState $ getActorBody target if bfidImpressed tb == bfid sb || bproj tb then return False else do execUpdAtomic $ UpdFidImpressedActor target (bfidImpressed tb) (bfid sb) return True -- ** CallFriend -- Note that the Calm expended doesn't depend on the number of actors called. effectCallFriend :: (MonadAtomic m, MonadServer m) => m () -> Dice.Dice -> ActorId -> ActorId -> m Bool effectCallFriend execSfx nDm source target = do -- Obvious effect, nothing announced. Kind.COps{cotile} <- getsState scops power <- rndToAction $ castDice (AbsDepth 0) (AbsDepth 0) nDm sb <- getsState $ getActorBody source tb <- getsState $ getActorBody target activeItems <- activeItemsServer target if not $ hpEnough10 tb activeItems then do unless (bproj tb) $ do let subject = partActor tb verb = "lack enough HP to call aid" msg = makeSentence [MU.SubjectVerbSg subject verb] execSfxAtomic $ SfxMsgFid (bfid sb) msg return False else do let deltaHP = - xM 10 execUpdAtomic $ UpdRefillHP target deltaHP execSfx let validTile t = not $ Tile.hasFeature cotile TK.NoActor t ps <- getsState $ nearbyFreePoints validTile (bpos tb) (blid tb) time <- getsState $ getLocalTime (blid tb) -- We call target's friends so that AI monsters that test by throwing -- don't waste artifacts very valuable for heroes. Heroes should rather -- not test scrolls by throwing. recruitActors (take power ps) (blid tb) time (bfid tb) -- ** Summon -- Note that the Calm expended doesn't depend on the number of actors summoned. effectSummon :: (MonadAtomic m, MonadServer m) => m () -> Freqs ItemKind -> Dice.Dice -> ActorId -> ActorId -> m Bool effectSummon execSfx actorFreq nDm source target = do -- Obvious effect, nothing announced. Kind.COps{cotile} <- getsState scops power <- rndToAction $ castDice (AbsDepth 0) (AbsDepth 0) nDm sb <- getsState $ getActorBody source tb <- getsState $ getActorBody target activeItems <- activeItemsServer target if not $ calmEnough10 tb activeItems then do unless (bproj tb) $ do let subject = partActor tb verb = "lack enough Calm to summon" msg = makeSentence [MU.SubjectVerbSg subject verb] execSfxAtomic $ SfxMsgFid (bfid sb) msg return False else do let deltaCalm = - xM 10 unless (bproj tb) $ udpateCalm target deltaCalm execSfx let validTile t = not $ Tile.hasFeature cotile TK.NoActor t ps <- getsState $ nearbyFreePoints validTile (bpos tb) (blid tb) localTime <- getsState $ getLocalTime (blid tb) -- Make sure summoned actors start acting after the summoner. let targetTime = timeShift localTime $ ticksPerMeter $ bspeed tb activeItems afterTime = timeShift targetTime $ Delta timeClip bs <- forM (take power ps) $ \p -> do maid <- addAnyActor actorFreq (blid tb) afterTime (Just p) case maid of Nothing -> return False -- actorFreq is null; content writers... Just aid -> do b <- getsState $ getActorBody aid mleader <- getsState $ gleader . (EM.! bfid b) . sfactionD when (isNothing mleader) $ execUpdAtomic $ UpdLeadFaction (bfid b) Nothing (Just (aid, Nothing)) return True return $! or bs -- ** Ascend -- Note that projectiles can be teleported, too, for extra fun. effectAscend :: (MonadAtomic m, MonadServer m) => (IK.Effect -> m Bool) -> m () -> Int -> ActorId -> ActorId -> m Bool effectAscend recursiveCall execSfx k source target = do b1 <- getsState $ getActorBody target let lid1 = blid b1 pos1 = bpos b1 (lid2, pos2) <- getsState $ whereTo lid1 pos1 k . sdungeon sb <- getsState $ getActorBody source if braced b1 then do execSfxAtomic $ SfxMsgFid (bfid sb) "Braced actors are immune to translocation." return False else if lid2 == lid1 && pos2 == pos1 then do execSfxAtomic $ SfxMsgFid (bfid sb) "No more levels in this direction." -- We keep it useful even in shallow dungeons. recursiveCall $ IK.Teleport 30 -- powerful teleport else do 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 = Just target -- Move the actor to where the inhabitants were, if any. switchLevels2 lid2 pos2 (target, b1) 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) 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) -> 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 $ fst <$> 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. ais <- getsState $ getCarriedAssocs bOld execUpdAtomic $ UpdLoseActor aid bOld ais return mlead switchLevels2 ::(MonadAtomic m, MonadServer m) => LevelId -> Point -> (ActorId, Actor) -> Maybe ActorId -> m () switchLevels2 lidNew posNew (aid, bOld) mlead = do let lidOld = blid bOld side = bfid bOld let !_A = assert (lidNew /= lidOld `blame` "stairs looped" `twith` lidNew) () -- Sync the actor time with the level time. timeOld <- getsState $ getLocalTime lidOld timeLastActive <- 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 = timeLastActive `timeDeltaToFrom` timeOld shiftByDelta = (`timeShift` delta) computeNewTimeout :: ItemQuant -> ItemQuant computeNewTimeout (k, it) = (k, map shiftByDelta it) setTimeout :: ItemBag -> ItemBag setTimeout = EM.map computeNewTimeout bNew = bOld { blid = lidNew , btime = shiftByDelta $ btime bOld , bpos = posNew , boldpos = Just posNew -- new level, new direction , boldlid = lidOld -- record old level , borgan = setTimeout $ borgan bOld , beqp = setTimeout $ beqp 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. ais <- getsState $ getCarriedAssocs bOld execUpdAtomic $ UpdCreateActor aid bNew ais case mlead of Nothing -> return () Just leader -> execUpdAtomic $ UpdLeadFaction side Nothing (Just (leader, Nothing)) -- ** Escape -- | The faction leaves the dungeon. effectEscape :: (MonadAtomic m, MonadServer m) => ActorId -> ActorId -> m Bool effectEscape source target = do -- Obvious effect, nothing announced. sb <- getsState $ getActorBody source b <- getsState $ getActorBody target let fid = bfid b fact <- getsState $ (EM.! fid) . sfactionD if bproj b then return False else if not (fcanEscape $ gplayer fact) then do execSfxAtomic $ SfxMsgFid (bfid sb) "This faction doesn't want to escape outside." return False else do deduceQuits fid Nothing $ Status Escape (fromEnum $ blid b) Nothing 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 () -> Dice.Dice -> ActorId -> m Bool effectParalyze execSfx nDm target = do p <- rndToAction $ castDice (AbsDepth 0) (AbsDepth 0) nDm 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 -- | 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 () -> Dice.Dice -> ActorId -> m Bool effectInsertMove execSfx nDm target = do p <- rndToAction $ castDice (AbsDepth 0) (AbsDepth 0) nDm b <- getsState $ getActorBody target activeItems <- activeItemsServer target let tpm = ticksPerMeter $ bspeed b activeItems t = timeDeltaScale tpm (-p) execUpdAtomic $ UpdAgeActor target t execSfx return True -- ** Teleport -- | Teleport the target actor. -- Note that projectiles can be teleported, too, for extra fun. effectTeleport :: (MonadAtomic m, MonadServer m) => m () -> Dice.Dice -> ActorId -> ActorId -> m Bool effectTeleport execSfx nDm source target = do Kind.COps{cotile} <- getsState scops range <- rndToAction $ castDice (AbsDepth 0) (AbsDepth 0) nDm sb <- getsState $ getActorBody source 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 TK.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 braced b then do execSfxAtomic $ SfxMsgFid (bfid sb) "Braced actors are immune to translocation." return False else if not (dMinMax 9 tpos) then do -- very rare execSfxAtomic $ SfxMsgFid (bfid sb) "Translocation not possible." return False else do execUpdAtomic $ UpdMoveActor target spos tpos execSfx return True -- ** CreateItem -- TODO: if the items is created not on the ground, perhaps it should -- be IDed, so that there are no rings with unkown max Calm bonus -- leading to attempts to do illegal actions (which the server then catches). -- This is in analogy to picking item from the ground, whereas it's IDed. effectCreateItem :: (MonadAtomic m, MonadServer m) => ActorId -> CStore -> GroupName ItemKind -> IK.TimerDice -> m Bool effectCreateItem target store grp tim = do tb <- getsState $ getActorBody target delta <- case tim of IK.TimerNone -> return $ Delta timeZero IK.TimerGameTurn nDm -> do k <- rndToAction $ castDice (AbsDepth 0) (AbsDepth 0) nDm let !_A = assert (k >= 0) () return $! timeDeltaScale (Delta timeTurn) k IK.TimerActorTurn nDm -> do k <- rndToAction $ castDice (AbsDepth 0) (AbsDepth 0) nDm let !_A = assert (k >= 0) () activeItems <- activeItemsServer target let actorTurn = ticksPerMeter $ bspeed tb activeItems return $! timeDeltaScale actorTurn k let c = CActor target store bagBefore <- getsState $ getCBag c let litemFreq = [(grp, 1)] -- Power depth of new items unaffected by number of spawned actors. m5 <- rollItem 0 (blid tb) litemFreq let (itemKnown, itemFull, _, seed, _) = fromMaybe (assert `failure` (blid tb, litemFreq, c)) m5 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, (1, afterIt@(timer : rest))) | tim /= IK.TimerNone -> do -- Already has such an item, so only increase the timer by half delta. let newIt = let halfTurns = delta `timeDeltaDiv` 2 newTimer = timer `timeShift` halfTurns in newTimer : rest when (afterIt /= newIt) $ execUpdAtomic $ UpdTimeItem iid c afterIt newIt -- TODO: announce _ -> do -- Multiple such items, so it's a periodic poison, etc., so just stack, -- or no such items at all, so create some. iid <- registerItem itemFull itemKnown seed (itemK itemFull) c True unless (tim == IK.TimerNone) $ do bagAfter <- getsState $ getCBag c localTime <- getsState $ getLocalTime (blid tb) let newTimer = localTime `timeShift` delta (afterK, afterIt) = fromMaybe (assert `failure` (iid, bagAfter, c)) (iid `EM.lookup` bagAfter) newIt = replicate afterK newTimer when (afterIt /= newIt) $ execUpdAtomic $ UpdTimeItem iid c afterIt newIt return True -- ** DropItem -- | Make the target actor drop all items in his equiment with the given symbol -- (not just a random single item, or cluttering equipment with rubbish -- would be beneficial). effectDropItem :: (MonadAtomic m, MonadServer m) => m () -> CStore -> GroupName ItemKind -> Bool -> ActorId -> m Bool effectDropItem execSfx store grp hit target = do Kind.COps{coitem=Kind.Ops{okind}} <- getsState scops discoKind <- getsServer sdiscoKind b <- getsState $ getActorBody target let hasGroup (iid, _) = do item <- getsState $ getItemBody iid case EM.lookup (jkindIx item) discoKind of Just kindId -> return $! maybe False (> 0) $ lookup grp $ IK.ifreq (okind kindId) Nothing -> assert `failure` (target, grp, iid, item) assocsCStore <- getsState $ EM.assocs . getActorBag target store is <- filterM hasGroup assocsCStore if null is then return False else do mapM_ (uncurry (dropCStoreItem store target b hit)) is unless (store == COrgan) execSfx return True -- | Drop a single actor's item. 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). dropCStoreItem :: (MonadAtomic m, MonadServer m) => CStore -> ActorId -> Actor -> Bool -> ItemId -> ItemQuant -> m () dropCStoreItem store aid b hit iid kit@(k, _) = do item <- getsState $ getItemBody iid let c = CActor aid store fragile = IK.Fragile `elem` jfeature item durable = IK.Durable `elem` jfeature item isDestroyed = hit && not durable || bproj b && fragile if isDestroyed then do discoEffect <- getsServer sdiscoEffect let aspects = case EM.lookup iid discoEffect of Just ItemAspectEffect{jaspects} -> jaspects _ -> assert `failure` (aid, iid) itemToF <- itemToFullServer let itemFull = itemToF iid kit effs = strengthOnSmash itemFull effectAndDestroy aid aid iid c False effs aspects kit else do mvCmd <- generalMoveItem iid k (CActor aid store) (CActor aid CGround) mapM_ execUpdAtomic mvCmd -- ** PolyItem -- TODO: ask player for an item effectPolyItem :: (MonadAtomic m, MonadServer m) => m () -> ActorId -> ActorId -> m Bool effectPolyItem execSfx source target = do sb <- getsState $ getActorBody source let cstore = CGround allAssocs <- fullAssocsServer target [cstore] case allAssocs of [] -> do execSfxAtomic $ SfxMsgFid (bfid sb) $ "The purpose of repurpose cannot be availed without an item" <+> ppCStoreIn cstore <> "." return False (iid, itemFull@ItemFull{..}) : _ -> case itemDisco of Just ItemDisco{..} -> do discoEffect <- getsServer sdiscoEffect let maxCount = Dice.maxDice $ IK.icount itemKind aspects = jaspects $ discoEffect EM.! iid if itemK < maxCount then do execSfxAtomic $ SfxMsgFid (bfid sb) $ "The purpose of repurpose is served by" <+> tshow maxCount <+> "pieces of this item, not by" <+> tshow itemK <> "." return False else if IK.Unique `elem` aspects then do execSfxAtomic $ SfxMsgFid (bfid sb) "Unique items can't be repurposed." return False else do let c = CActor target cstore kit = (maxCount, take maxCount itemTimer) identifyIid execSfx iid c itemKindId execUpdAtomic $ UpdDestroyItem iid itemBase kit c effectCreateItem target cstore "useful" IK.TimerNone _ -> assert `failure` (target, iid, itemFull) -- ** Identify -- TODO: ask player for an item, because server doesn't know which -- is already identified, it only knows which cannot ever be. -- Perhaps refill Calm only when id successfull and scroll consumed, -- id the scroll anyway. Explain the Calm gain: "your most pressing -- existential concerns are answered scientifitically". effectIdentify :: (MonadAtomic m, MonadServer m) => m () -> ItemId -> ActorId -> ActorId -> m Bool effectIdentify execSfx iidId source target = do sb <- getsState $ getActorBody source let tryFull store as = case as of -- TODO: identify the scroll, but don't use up. [] -> do let (tIn, t) = ppCStore store msg = "Nothing to identify" <+> tIn <+> t <> "." execSfxAtomic $ SfxMsgFid (bfid sb) msg return False (iid, _) : rest | iid == iidId -> tryFull store rest -- don't id itself (iid, itemFull@ItemFull{itemDisco=Just ItemDisco{..}}) : rest -> do -- TODO: use this (but faster, via traversing effects with 999?) -- also to prevent sending any other UpdDiscover. let ided = IK.Identified `elem` IK.ifeature itemKind itemSecret = itemNoAE itemFull statsObvious = textAllAE 7 False store itemFull == textAllAE 7 False store itemSecret if ided && statsObvious then tryFull store rest else do let c = CActor target store identifyIid execSfx iid c itemKindId return True _ -> assert `failure` (store, as) tryStore stores = case stores of [] -> return False store : rest -> do allAssocs <- fullAssocsServer target [store] go <- tryFull store allAssocs if go then return True else tryStore rest tryStore [CGround] identifyIid :: (MonadAtomic m, MonadServer m) => m () -> ItemId -> Container -> Kind.Id ItemKind -> m () identifyIid execSfx iid c itemKindId = do execSfx seed <- getsServer $ (EM.! iid) . sitemSeedD item <- getsState $ getItemBody iid Level{ldepth} <- getLevel $ jlid item execUpdAtomic $ UpdDiscover c iid itemKindId seed ldepth -- ** 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 () -> IK.ThrowMod -> ActorId -> ActorId -> Maybe Bool -> m Bool effectSendFlying execSfx IK.ThrowMod{..} source target modePush = do v <- sendFlyingVector source target modePush Kind.COps{cotile} <- getsState scops sb <- getsState $ getActorBody source tb <- getsState $ getActorBody target lvl@Level{lxsize, lysize} <- getLevel (blid tb) let eps = 0 fpos = bpos tb `shift` v if braced tb then do execSfxAtomic $ SfxMsgFid (bfid sb) "Braced actors are immune to translocation." return False else 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) if null trajectory || btrajectory tb == ts || throwVelocity <= 0 || throwLinger <= 0 then return False -- e.g., actor is too heavy; OK else do execUpdAtomic $ UpdTrajectory target (btrajectory tb) ts -- Give the actor one extra turn and also let the push start ASAP. -- So, if the push lasts one (his) turn, he will not lose -- any turn of movement (but he may need to retrace the push). activeItems <- activeItemsServer target let tpm = ticksPerMeter $ bspeed tb activeItems delta = timeDeltaScale tpm (-1) execUpdAtomic $ UpdAgeActor target delta execSfx return True sendFlyingVector :: (MonadAtomic m, MonadServer m) => ActorId -> ActorId -> Maybe Bool -> m Vector sendFlyingVector source target modePush = do sb <- getsState $ getActorBody source let boldpos_sb = fromMaybe (Point 0 0) (boldpos sb) if source == target then 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 -- ** DropBestWeapon -- | Make the target actor drop his best weapon (stack). effectDropBestWeapon :: (MonadAtomic m, MonadServer m) => m () -> ActorId -> m Bool effectDropBestWeapon execSfx target = do tb <- getsState $ getActorBody target allAssocs <- fullAssocsServer target [CEqp] localTime <- getsState $ getLocalTime (blid tb) case strongestMelee False localTime allAssocs of (_, (iid, _)) : _ -> do let kit = beqp tb EM.! iid dropCStoreItem CEqp target tb False iid kit execSfx return True [] -> return False -- ** ActivateInv -- | Activate all 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 = effectTransformEqp execSfx target symbol CInv $ \iid _ -> applyItem target iid CInv effectTransformEqp :: forall m. (MonadAtomic m, MonadServer m) => m () -> ActorId -> Char -> CStore -> (ItemId -> ItemQuant -> 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 -- ** 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 -- ** OneOf effectOneOf :: (MonadAtomic m, MonadServer m) => (IK.Effect -> m Bool) -> [IK.Effect] -> m Bool effectOneOf recursiveCall l = do let call1 = do ef <- rndToAction $ oneOf l recursiveCall ef call99 = replicate 99 call1 f callNext result = do b <- result if b then return True else callNext foldr f (return False) call99 -- ** Recharging effectRecharging :: (MonadAtomic m, MonadServer m) => (IK.Effect -> m Bool) -> IK.Effect -> Bool -> m Bool effectRecharging recursiveCall e recharged = if recharged then recursiveCall e else return False -- ** Temporary effectTemporary :: (MonadAtomic m, MonadServer m) => m () -> ActorId -> ItemId -> m Bool effectTemporary execSfx source iid = do bag <- getsState $ getCBag $ CActor source COrgan case iid `EM.lookup` bag of Just _ -> return () -- still some copies left of a multi-copy tmp item Nothing -> execSfx -- last copy just destroyed return True LambdaHack-0.5.0.0/Game/LambdaHack/Server/CommonServer.hs0000644000000000000000000005355112555256425021074 0ustar0000000000000000{-# 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.List import Data.Maybe import Data.Text (Text) import qualified Data.Text as T import qualified NLP.Miniutter.English as MU import qualified Text.Show.Pretty as Show.Pretty 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 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 (ItemKind) import qualified Game.LambdaHack.Content.ItemKind as IK 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 impossible = impossibleReqFailure failureSer debugShow :: Show a => a -> Text debugShow = T.pack . Show.Pretty.ppShow possiblyAlarm = if impossible then debugPossiblyPrintAndExit else debugPossiblyPrint possiblyAlarm $ "execFailure:" <+> msg <> "\n" <> debugShow body <> "\n" <> debugShow 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 sfovMode <- getsServer $ sfovMode . sdebugSer lvl <- getLevel lid let fovMode = fromMaybe Digital sfovMode per = fidLidPerception 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 failFact = assert `failure` "no perception for faction" `twith` (lid, fid) fper = EM.findWithDefault failFact fid pers failLvl = assert `failure` "no perception for level" `twith` (lid, fid) per = EM.findWithDefault failLvl lid fper return $! per revealItems :: (MonadAtomic m, MonadServer m) => Maybe FactionId -> Maybe (ActorId, Actor) -> m () revealItems mfid mbody = do let !_A = assert (maybe True (not . bproj . snd) mbody) () itemToF <- itemToFullServer dungeon <- getsState sdungeon let discover aid store iid k = let itemFull = itemToF iid k c = CActor aid store in case itemDisco itemFull of Just ItemDisco{itemKindId} -> do seed <- getsServer $ (EM.! iid) . sitemSeedD Level{ldepth} <- getLevel $ jlid $ itemBase itemFull execUpdAtomic $ UpdDiscover c iid itemKindId seed ldepth _ -> assert `failure` (mfid, mbody, c, iid, itemFull) f aid = do b <- getsState $ getActorBody aid let ourSide = maybe True (== bfid b) mfid -- Don't ID projectiles, because client may not see them. when (not (bproj b) && ourSide) $ -- CSha is IDed for each actor of each faction, which is OK, -- even though it may introduce a slight lag. -- AI clients being sent this is a bigger waste anyway. join $ getsState $ mapActorItems_ (discover aid) b mapDungeonActors_ f dungeon maybe (return ()) (\(aid, b) -> join $ getsState $ mapActorItems_ (discover aid) 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 (ActorId, Actor) -> Status -> FactionId -> m () quitF mbody status fid = do let !_A = assert (maybe True ((fid ==) . bfid . snd) mbody) () fact <- getsState $ (EM.! fid) . sfactionD let oldSt = gquit fact 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 when (fhasUI $ gplayer fact) $ do keepAutomated <- getsServer $ skeepAutomated . sdebugSer when (isAIFact fact && fleaderMode (gplayer fact) /= LeaderNull && not keepAutomated) $ execUpdAtomic $ UpdAutoFaction fid False revealItems (Just fid) mbody registerScore status (snd <$> mbody) fid execUpdAtomic $ UpdQuitFaction fid (snd <$> mbody) oldSt $ Just status -- TODO: send only aid to UpdQuitFaction and elsewhere --- aid is alive 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) => FactionId -> Maybe (ActorId, Actor) -> Status -> m () deduceQuits fid mbody status@Status{stOutcome} | stOutcome `elem` [Defeated, Camping, Restart, Conquer] = assert `failure` "no quitting to deduce" `twith` (fid, mbody, status) deduceQuits fid mbody status = do let mapQuitF statusF fids = mapM_ (quitF Nothing statusF) $ delete fid fids quitF mbody status fid let inGameOutcome (_, fact) = case stOutcome <$> gquit fact of Just Killed -> False Just Defeated -> False Just Restart -> False -- effectively, commits suicide _ -> True factionD <- getsState sfactionD let assocsInGame = filter inGameOutcome $ EM.assocs factionD keysInGame = map fst assocsInGame assocsKeepArena = filter (keepArenaFact . snd) assocsInGame assocsUI = filter (fhasUI . gplayer . snd) assocsInGame nonHorrorAIG = filter (not . isHorrorFact . snd) assocsInGame worldPeace = all (\(fid1, _) -> all (\(_, fact2) -> not $ isAtWar fact2 fid1) nonHorrorAIG) nonHorrorAIG 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 get stuck in a state with no active arena and so no spawns. 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) assocsInGame mapQuitF status{stOutcome=Escape} $ map fst victors mapQuitF status{stOutcome=Defeated} $ map fst losers _ -> 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 = fleaderMode (gplayer fact) /= LeaderNull && fneverEmpty (gplayer fact) -- We assume the actor in the second argumet is dead or dominated -- by this point. Even if the actor is to be dominated, -- @bfid@ of the actor body is still the old faction. deduceKilled :: (MonadAtomic m, MonadServer m) => ActorId -> Actor -> m () deduceKilled aid body = do Kind.COps{corule} <- getsState scops let firstDeathEnds = rfirstDeathEnds $ Kind.stdRuleset corule fid = bfid body fact <- getsState $ (EM.! fid) . sfactionD when (fneverEmpty $ gplayer fact) $ do actorsAlive <- anyActorsAlive fid (Just aid) when (not actorsAlive || firstDeathEnds) $ deduceQuits fid (Just (aid, body)) $ Status Killed (fromEnum $ blid body) Nothing anyActorsAlive :: MonadServer m => FactionId -> Maybe ActorId -> m Bool anyActorsAlive fid maid = do fact <- getsState $ (EM.! fid) . sfactionD if fleaderMode (gplayer fact) /= LeaderNull then return $! isJust $ gleader fact else do as <- getsState $ fidActorNotProjAssocs fid return $! not $ null $ maybe as (\aid -> filter ((/= aid) . fst) as) maid electLeader :: MonadAtomic m => FactionId -> LevelId -> ActorId -> m () electLeader fid lid aidDead = do mleader <- getsState $ gleader . (EM.! fid) . sfactionD when (isNothing mleader || fmap fst 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 = case filter (/= aidDead) $ map fst $ onLevel ++ party of [] -> Nothing aid : _ -> Just (aid, Nothing) 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 blast -> m (Maybe ReqFailure) projectFail source tpxy eps iid cstore isBlast = 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 bag <- getsState $ getActorBag source cstore case EM.lookup iid bag of Nothing -> return $ Just ProjectOutOfReach Just kit -> do itemToF <- itemToFullServer activeItems <- activeItemsServer source actorSk <- actorSkillsServer source let skill = EM.findWithDefault 0 Ability.AbProject actorSk itemFull@ItemFull{itemBase} = itemToF iid kit forced = isBlast || bproj sb legal = permittedProject " " forced skill itemFull sb activeItems case legal of Left reqFail -> return $ Just reqFail Right _ -> do let fragile = IK.Fragile `elem` jfeature itemBase 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 lab <- getsState $ posToActors pos lid if not $ all (bproj . snd) lab then if isBlast && bproj sb then do -- Hit the blocking actor. projectBla source spos (pos:rest) iid cstore isBlast return Nothing else return $ Just ProjectBlockActor else do if isBlast && bproj sb && eps `mod` 2 == 0 then -- Make the explosion a bit less regular. projectBla source spos (pos:rest) iid cstore isBlast else projectBla source pos rest iid cstore isBlast 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 blast -> m () projectBla source pos rest iid cstore isBlast = do sb <- getsState $ getActorBody source item <- getsState $ getItemBody iid let lid = blid sb localTime <- getsState $ getLocalTime lid unless isBlast $ execSfxAtomic $ SfxProject source iid cstore bag <- getsState $ getActorBag source cstore case iid `EM.lookup` bag of Nothing -> assert `failure` (source, pos, rest, iid, cstore) Just kit@(_, it) -> do addProjectile pos rest iid kit lid (bfid sb) localTime isBlast let c = CActor source cstore execUpdAtomic $ UpdLoseItem iid item (1, take 1 it) 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 -> ItemQuant -> LevelId -> FactionId -> Time -> Bool -> m () addProjectile bpos rest iid (_, it) blid bfid btime isBlast = do localTime <- getsState $ getLocalTime blid itemToF <- itemToFullServer let itemFull@ItemFull{itemBase} = itemToF iid (1, take 1 it) (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 localTime (itemNoDisco (itemBase, 1)) bname = makePhrase [MU.AW $ MU.Text adj, object1, object2] tweakBody b = b { bsymbol = if isBlast then bsymbol b else '*' , bcolor = if isBlast then bcolor b else Color.BrWhite , bname , bhp = 1 , bproj = True , btrajectory = Just (trajectory, speed) , beqp = EM.singleton iid (1, take 1 it) , borgan = EM.empty} bpronoun = "it" void $ addActorIid iid itemFull True bfid bpos blid tweakBody bpronoun btime addActor :: (MonadAtomic m, MonadServer m) => GroupName ItemKind -> 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 Nothing case m2 of Nothing -> return Nothing Just (trunkId, (trunkFull, _)) -> addActorIid trunkId trunkFull False bfid pos lid tweakBody bpronoun time addActorIid :: (MonadAtomic m, MonadServer m) => ItemId -> ItemFull -> Bool -> FactionId -> Point -> LevelId -> (Actor -> Actor) -> Text -> Time -> m (Maybe ActorId) addActorIid trunkId trunkFull@ItemFull{..} bproj 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 IK.EqpSlotAddMaxHP [trunkFull]) `div` 2 calm = xM $ max 1 $ sumSlotNoFilter IK.EqpSlotAddMaxCalm [trunkFull] -- Create actor. factionD <- getsState sfactionD let factMine = factionD EM.! bfid DebugModeSer{scurDiffSer} <- getsServer sdebugSer nU <- nUI -- 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 scurDiffSer hasUIorEscapes Faction{gplayer} = fhasUI gplayer || nU == 0 && fcanEscape gplayer boostFact = not bproj && if diffBonusCoeff > 0 then hasUIorEscapes factMine || any hasUIorEscapes (filter (`isAllied` bfid) $ EM.elems factionD) else any hasUIorEscapes (filter (`isAtWar` bfid) $ EM.elems factionD) diffHP | boostFact = hp * 2 ^ abs diffBonusCoeff | otherwise = hp bonusHP = fromIntegral $ (diffHP - hp) `divUp` oneM healthOrgans = [(Just bonusHP, ("bonus HP", COrgan)) | bonusHP /= 0] bsymbol = jsymbol itemBase bname = IK.iname trunkKind 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, itemTimer)} aid <- getsServer sacounter modifyServer $ \ser -> ser {sacounter = succ aid} execUpdAtomic $ UpdCreateActor aid (tweakBody withTrunk) [(trunkId, itemBase)] -- Create, register and insert all initial actor items, including -- the bonus health organs from difficulty setting. forM_ (healthOrgans ++ map (Nothing,) (IK.ikit trunkKind)) $ \(mk, (ikText, cstore)) -> do let container = CActor aid cstore itemFreq = [(ikText, 1)] mIidEtc <- rollAndRegisterItem lid itemFreq container False mk case mIidEtc of Nothing -> assert `failure` (lid, itemFreq, container, mk) Just (_, (ItemFull{itemDisco= Just ItemDisco{itemAE= Just ItemAspectEffect{jeffects=_:_}}}, _)) -> return () -- discover by use Just (iid, (ItemFull{itemBase=itemBase2}, _)) -> do seed <- getsServer $ (EM.! iid) . sitemSeedD Level{ldepth} <- getLevel $ jlid itemBase2 execUpdAtomic $ UpdDiscoverSeed container iid seed ldepth 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 eqpAssocs <- fullAssocsServer source [CEqp] bodyAssocs <- fullAssocsServer source [COrgan] actorSk <- actorSkillsServer source sb <- getsState $ getActorBody source localTime <- getsState $ getLocalTime (blid sb) -- For projectiles we need to accept even items without any effect, -- so that the projectile dissapears and "No effect" feedback is produced. let allAssocs = eqpAssocs ++ bodyAssocs calm10 = calmEnough10 sb $ map snd allAssocs forced = bproj sb permitted = permittedPrecious calm10 forced legalPrecious = either (const False) (const True) . permitted preferredPrecious = either (const False) id . permitted strongest = strongestMelee True localTime allAssocs strongestLegal = filter (legalPrecious . snd . snd) strongest strongestPreferred = filter (preferredPrecious . snd . snd) strongestLegal best = case strongestPreferred of _ | bproj sb -> map (1,) eqpAssocs _ | EM.findWithDefault 0 Ability.AbMelee actorSk <= 0 -> [] _:_ -> strongestPreferred [] -> strongestLegal case best of [] -> return Nothing iis@((maxS, _) : _) -> do let maxIis = map snd $ takeWhile ((== maxS) . fst) iis (iid, _) <- rndToAction $ oneOf maxIis let cstore = if isJust (lookup iid bodyAssocs) then COrgan else CEqp return $ Just (iid, cstore) sumOrganEqpServer :: MonadServer m => IK.EqpSlot -> ActorId -> m Int sumOrganEqpServer eqpSlot aid = do activeAssocs <- activeItemsServer aid return $! sumSlotNoFilter eqpSlot activeAssocs actorSkillsServer :: MonadServer m => ActorId -> m Ability.Skills actorSkillsServer aid = do activeItems <- activeItemsServer aid body <- getsState $ getActorBody aid fact <- getsState $ (EM.! bfid body) . sfactionD let mleader = fst <$> gleader fact getsState $ actorSkills mleader aid activeItems LambdaHack-0.5.0.0/Game/LambdaHack/Server/ItemServer.hs0000644000000000000000000002217012555256425020533 0ustar0000000000000000-- | Server operations for items. module Game.LambdaHack.Server.ItemServer ( rollItem, rollAndRegisterItem, registerItem , placeItemsInDungeon, embedItemsInDungeon, fullAssocsServer , activeItemsServer, itemToFullServer, mapActorCStore_ ) where import Control.Monad import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES import Data.Function import qualified Data.HashMap.Strict as HM import Data.List import Data.Maybe import Data.Ord 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.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.Msg 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.Content.ItemKind (ItemKind) import qualified Game.LambdaHack.Content.ItemKind as IK import Game.LambdaHack.Content.TileKind (TileKind) import qualified Game.LambdaHack.Content.TileKind as TK import Game.LambdaHack.Server.ItemRev import Game.LambdaHack.Server.MonadServer import Game.LambdaHack.Server.State registerItem :: (MonadAtomic m, MonadServer m) => ItemFull -> ItemKnown -> ItemSeed -> Int -> Container -> Bool -> m ItemId registerItem itemFull itemKnown@(_, 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 (itemBase itemFull) (k, []) container return iid Nothing -> do let fovSight = fromMaybe 0 $ strengthFromEqpSlot IK.EqpSlotAddSight itemFull fovSmell = fromMaybe 0 $ strengthFromEqpSlot IK.EqpSlotAddSmell itemFull fovLight = fromMaybe 0 $ strengthFromEqpSlot IK.EqpSlotAddLight itemFull ssl = FovCache3{..} icounter <- getsServer sicounter modifyServer $ \ser -> ser { sdiscoEffect = EM.insert icounter iae (sdiscoEffect ser) , sitemSeedD = EM.insert icounter seed (sitemSeedD ser) , sitemRev = HM.insert itemKnown icounter (sitemRev ser) , sItemFovCache = if ssl == emptyFovCache3 then sItemFovCache ser else EM.insert icounter ssl (sItemFovCache ser) , sicounter = succ icounter } execUpdAtomic $ cmd icounter (itemBase itemFull) (k, []) container return $! icounter createLevelItem :: (MonadAtomic m, MonadServer m) => Point -> LevelId -> m () createLevelItem pos lid = do Level{litemFreq} <- getLevel lid let container = CFloor lid pos void $ rollAndRegisterItem lid litemFreq container True Nothing embedItem :: (MonadAtomic m, MonadServer m) => LevelId -> Point -> Kind.Id TileKind -> m () embedItem lid pos tk = do Kind.COps{cotile} <- getsState scops let embeds = Tile.embedItems cotile tk causes = Tile.causeEffects cotile tk -- TODO: unhack this, e.g., by turning each Cause into Embed itemFreq = zip embeds (repeat 1) ++ -- Hack: the bag, not item, is relevant. [("hero", 1) | not (null causes) && null embeds] container = CEmbed lid pos void $ rollAndRegisterItem lid itemFreq container False Nothing rollItem :: (MonadAtomic m, MonadServer m) => Int -> LevelId -> Freqs ItemKind -> m (Maybe ( ItemKnown, ItemFull, ItemDisco , ItemSeed, GroupName ItemKind )) rollItem lvlSpawned lid itemFreq = do cops <- getsState scops flavour <- getsServer sflavour discoRev <- getsServer sdiscoKindRev uniqueSet <- getsServer suniqueSet totalDepth <- getsState stotalDepth Level{ldepth} <- getLevel lid m5 <- rndToAction $ newItem cops flavour discoRev uniqueSet itemFreq lvlSpawned lid ldepth totalDepth case m5 of Just (_, _, ItemDisco{ itemKindId , itemAE=Just ItemAspectEffect{jaspects}}, _, _) -> when (IK.Unique `elem` jaspects) $ modifyServer $ \ser -> ser {suniqueSet = ES.insert itemKindId (suniqueSet ser)} _ -> return () return m5 rollAndRegisterItem :: (MonadAtomic m, MonadServer m) => LevelId -> Freqs ItemKind -> Container -> Bool -> Maybe Int -> m (Maybe (ItemId, (ItemFull, GroupName ItemKind))) rollAndRegisterItem lid itemFreq container verbose mk = do -- Power depth of new items unaffected by number of spawned actors. m5 <- rollItem 0 lid itemFreq case m5 of Nothing -> return Nothing Just (itemKnown, itemFullRaw, itemDisco, seed, itemGroup) -> do let item = itemBase itemFullRaw trunkName = makePhrase [MU.WownW (MU.Text $ jname item) "trunk"] itemTrunk = if null $ IK.ikit $ itemKind itemDisco then item else item {jname = trunkName} itemFull = itemFullRaw { itemK = fromMaybe (itemK itemFullRaw) mk , itemBase = itemTrunk } iid <- registerItem itemFull itemKnown seed (itemK itemFull) container verbose return $ Just (iid, (itemFull, itemGroup)) placeItemsInDungeon :: forall m. (MonadAtomic m, MonadServer m) => m () placeItemsInDungeon = do Kind.COps{cotile} <- getsState scops let initialItems (lid, Level{lfloor, ltile, litemNum, lxsize, lysize}) = do let factionDist = max lxsize lysize - 5 placeItems :: [Point] -> Int -> m () placeItems _ 0 = return () placeItems lfloorKeys n = do let dist p = minimum $ maxBound : map (chessDist p) lfloorKeys pos <- rndToAction $ findPosTry 500 ltile (\_ t -> Tile.isWalkable cotile t && not (Tile.hasFeature cotile TK.NoItem t)) [ \p t -> Tile.hasFeature cotile TK.OftenItem t && dist p > factionDist `div` 5 , \p t -> Tile.hasFeature cotile TK.OftenItem t && dist p > factionDist `div` 7 , \p t -> Tile.hasFeature cotile TK.OftenItem t && dist p > factionDist `div` 9 , \p t -> Tile.hasFeature cotile TK.OftenItem t && dist p > factionDist `div` 12 , \p _ -> dist p > factionDist `div` 5 , \p t -> Tile.hasFeature cotile TK.OftenItem t || dist p > factionDist `div` 7 , \p t -> Tile.hasFeature cotile TK.OftenItem t || dist p > factionDist `div` 9 , \p t -> Tile.hasFeature cotile TK.OftenItem t || dist p > factionDist `div` 12 , \p _ -> dist p > 1 , \p _ -> dist p > 0 ] createLevelItem pos lid placeItems (pos : lfloorKeys) (n - 1) placeItems (EM.keys lfloor) litemNum dungeon <- getsState sdungeon -- Make sure items on easy levels are generated first, to avoid all -- artifacts on deep levels. let absLid = abs . fromEnum fromEasyToHard = sortBy (comparing absLid `on` fst) $ EM.assocs dungeon mapM_ initialItems fromEasyToHard embedItemsInDungeon :: (MonadAtomic m, MonadServer m) => m () embedItemsInDungeon = do let embedItems (lid, Level{ltile}) = PointArray.mapWithKeyMA (embedItem lid) ltile dungeon <- getsState sdungeon -- Make sure items on easy levels are generated first, to avoid all -- artifacts on deep levels. let absLid = abs . fromEnum fromEasyToHard = sortBy (comparing absLid `on` fst) $ EM.assocs dungeon mapM_ embedItems fromEasyToHard fullAssocsServer :: MonadServer m => ActorId -> [CStore] -> m [(ItemId, ItemFull)] fullAssocsServer aid cstores = do cops <- getsState scops discoKind <- getsServer sdiscoKind discoEffect <- getsServer sdiscoEffect getsState $ fullAssocs cops discoKind discoEffect 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 -> ItemQuant -> ItemFull) itemToFullServer = do cops <- getsState scops discoKind <- getsServer sdiscoKind discoEffect <- getsServer sdiscoEffect s <- getState let itemToF iid = itemToFull cops discoKind discoEffect iid (getItemBody iid s) return itemToF -- | Mapping over actor's items from a give store. mapActorCStore_ :: MonadServer m => CStore -> (ItemId -> ItemQuant -> m a) -> Actor -> m () mapActorCStore_ cstore f b = do bag <- getsState $ getBodyActorBag b cstore mapM_ (uncurry f) $ EM.assocs bag LambdaHack-0.5.0.0/Game/LambdaHack/Server/Commandline.hs0000644000000000000000000001365712555256425020706 0ustar0000000000000000-- | 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.Common.Misc import Game.LambdaHack.Server.State -- TODO: make more maintainable -- | Parse server debug parameters from commandline arguments. 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" , " --keepAutomated keep factions automated after game over" , " --newGame n start a new game, overwriting the save file," , " with difficulty for all UI players set 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" , " --noColorIsBold don't use bold attribute for colorful characters" , " --maxFps n display at most n frames per second" , " --noDelay don't maintain any requested delays between frames" , " --disableAutoYes never 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" ] 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 = Just $ toGroupName (T.pack s)} parseArgs ("--automateAll" : rest) = (parseArgs rest) {sautomateAll = True} parseArgs ("--keepAutomated" : rest) = (parseArgs rest) {skeepAutomated = True} parseArgs ("--newGame" : s : rest) = let debugSer = parseArgs rest scurDiffSer = read s in debugSer { scurDiffSer , snewGameSer = True , sdebugCli = (sdebugCli debugSer) {snewGameCli = True}} parseArgs ("--stopAfter" : s : rest) = (parseArgs rest) {sstopAfter = Just $ read s} parseArgs ("--benchmark" : rest) = let debugSer = parseArgs rest in debugSer {sdebugCli = (sdebugCli debugSer) {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 ("--noColorIsBold" : rest) = let debugSer = parseArgs rest in debugSer {sdebugCli = (sdebugCli debugSer) {scolorIsBold = Just False}} 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 ("--disableAutoYes" : rest) = let debugSer = parseArgs rest in debugSer {sdebugCli = (sdebugCli debugSer) {sdisableAutoYes = 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 LambdaHack-0.5.0.0/Game/LambdaHack/Server/ItemRev.hs0000644000000000000000000001577412555256425020035 0ustar0000000000000000{-# 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, UniqueSet -- * Item discovery types , DiscoveryKindRev, serverDiscos, ItemSeedDict -- * The @FlavourMap@ type , FlavourMap, emptyFlavourMap, dungeonFlavourMap ) where import Control.Applicative 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.HashMap.Strict as HM import qualified Data.Ix as Ix import Data.List import qualified Data.Set as S 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 (ItemKind) import qualified Game.LambdaHack.Content.ItemKind as IK -- | The reverse map to @DiscoveryKind@, needed for item creation. type DiscoveryKindRev = EM.EnumMap (Kind.Id ItemKind) ItemKindIx -- | The map of item ids to item seeds, needed for item creation. type ItemSeedDict = EM.EnumMap ItemId ItemSeed type UniqueSet = ES.EnumSet (Kind.Id ItemKind) serverDiscos :: Kind.COps -> Rnd (DiscoveryKind, DiscoveryKindRev) serverDiscos Kind.COps{coitem=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 (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 -> DiscoveryKindRev -> Kind.Id ItemKind -> ItemKind -> LevelId -> Item buildItem (FlavourMap flavour) discoRev ikChosen kind jlid = let jkindIx = discoRev EM.! ikChosen jsymbol = IK.isymbol kind jname = IK.iname kind jflavour = case IK.iflavour kind of [fl] -> fl _ -> flavour EM.! ikChosen jfeature = IK.ifeature kind jweight = IK.iweight kind in Item{..} -- | Generate an item based on level. newItem :: Kind.COps -> FlavourMap -> DiscoveryKindRev -> UniqueSet -> Freqs ItemKind -> Int -> LevelId -> AbsDepth -> AbsDepth -> Rnd (Maybe ( ItemKnown, ItemFull, ItemDisco , ItemSeed, GroupName ItemKind )) newItem Kind.COps{coitem=Kind.Ops{ofoldrGroup}} flavour discoRev uniqueSet itemFreq lvlSpawned jlid ldepth@(AbsDepth ldAbs) totalDepth@(AbsDepth depth) = do -- Effective generation depth of actors (not items) increases with spawns. let scaledDepth = ldAbs * 10 `div` depth numSpawnedCoeff = lvlSpawned `div` 2 ldSpawned = max ldAbs -- the first fast spawns are of the nominal level $ min depth $ ldAbs + numSpawnedCoeff - scaledDepth findInterval _ x1y1 [] = (x1y1, (11, 0)) findInterval ld x1y1 ((x, y) : rest) = if fromIntegral ld * 10 <= x * fromIntegral depth then (x1y1, (x, y)) else findInterval ld (x, y) rest linearInterpolation ld dataset = -- We assume @dataset@ is sorted and between 0 and 10. let ((x1, y1), (x2, y2)) = findInterval ld (0, 0) dataset in ceiling $ fromIntegral y1 + fromIntegral (y2 - y1) * (fromIntegral ld * 10 - x1 * fromIntegral depth) / ((x2 - x1) * fromIntegral depth) f _ _ _ ik _ acc | ik `ES.member` uniqueSet = acc f itemGroup q p ik kind acc = -- Don't consider lvlSpawned for uniques. let ld = if IK.Unique `elem` IK.iaspects kind then ldAbs else ldSpawned rarity = linearInterpolation ld (IK.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 ldSpawned <> ")") freqDepth if nullFreq freq then return Nothing else do ((itemKindId, itemKind), itemGroup) <- frequency freq -- Number of new items/actors unaffected by number of spawned actors. itemN <- castDice ldepth totalDepth (IK.icount itemKind) seed <- fmap toEnum random let itemBase = buildItem flavour discoRev itemKindId itemKind jlid itemK = max 1 itemN itemTimer = [] itemDiscoData = ItemDisco {itemKindId, itemKind, itemAE = Just iae} itemDisco = Just itemDiscoData -- Bonuses on items/actors unaffected by number of spawned actors. iae = seedToAspectsEffects seed itemKind ldepth totalDepth itemFull = ItemFull {..} return $ Just ( (jkindIx itemBase, iae) , itemFull , itemDiscoData , seed , 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 for the same -- symbol, 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 = IK.iflavour ik in if length flavours == 1 then rnd else do (assocs, availableMap) <- rnd let available = EM.findWithDefault fullFlavSet (IK.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 (IK.isymbol ik) availableReduced availableMap) -- | Randomly chooses flavour for all item kinds for this game. dungeonFlavourMap :: Kind.COps -> Rnd FlavourMap dungeonFlavourMap Kind.COps{coitem=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 LambdaHack-0.5.0.0/Game/LambdaHack/Server/Fov.hs0000644000000000000000000002554512555256425017211 0ustar0000000000000000{-# LANGUAGE CPP #-} -- | Field Of View scanning with a variety of algorithms. -- See -- for discussion. module Game.LambdaHack.Server.Fov ( dungeonPerception, fidLidPerception , PersLit, litInDungeon #ifdef EXPOSE_INTERNAL -- * Internal operations , PerceptionReachable(..), PerceptionDynamicLit(..) #endif ) where import qualified Data.EnumMap.Lazy as EML import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES import Data.List import Data.Maybe 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.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.Vector import Game.LambdaHack.Content.RuleKind 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 positions (light passes through them to the actor). -- The list may contain (many) repetitions. newtype PerceptionReachable = PerceptionReachable {preachable :: [Point]} deriving Show -- | All positions lit by dynamic lights on a level. Shared by all factions. -- The list may contain (many) repetitions. newtype PerceptionDynamicLit = PerceptionDynamicLit {pdynamicLit :: [Point]} deriving Show -- | The cache of FOV information for a level, such as sight, smell -- and light radiuses for each actor and bitmaps of clear and lit positions. type PersLit = EML.EnumMap LevelId ( EM.EnumMap FactionId [(Actor, FovCache3)] , PointArray.Array Bool , PointArray.Array Bool ) -- | Calculate faction's perception of a level. levelPerception :: [(Actor, FovCache3)] -> PointArray.Array Bool -> PointArray.Array Bool -> FovMode -> Level -> Perception levelPerception actorEqpBody clearPs litPs fovMode Level{lxsize, lysize} = let -- Dying actors included, to let them see their own demise. ourR = preachable . reachableFromActor clearPs fovMode totalReachable = PerceptionReachable $ concatMap ourR actorEqpBody -- All non-projectile actors feel adjacent positions, -- even dark (for easy exploration). Projectiles rely on cameras. pAndVicinity p = p : vicinity lxsize lysize p gatherVicinities = concatMap (pAndVicinity . bpos . fst) nocteurs = filter (not . bproj . fst) actorEqpBody nocto = gatherVicinities nocteurs ptotal = visibleOnLevel totalReachable litPs nocto -- TODO: handle smell radius < 2, that is only under the actor -- Projectiles can potentially smell, too. canSmellAround FovCache3{fovSmell} = fovSmell >= 2 smellers = filter (canSmellAround . snd) actorEqpBody smells = gatherVicinities smellers -- No smell stored in walls and under other actors. canHoldSmell p = clearPs PointArray.! p psmell = PerceptionVisible $ ES.fromList $ filter canHoldSmell smells in Perception ptotal psmell -- | Calculate faction's perception of a level based on the lit tiles cache. fidLidPerception :: FovMode -> PersLit -> FactionId -> LevelId -> Level -> Perception fidLidPerception fovMode persLit fid lid lvl = let (bodyMap, clearPs, litPs) = persLit EML.! lid actorEqpBody = EM.findWithDefault [] fid bodyMap in levelPerception actorEqpBody clearPs litPs fovMode lvl -- | Calculate perception of a faction. factionPerception :: FovMode -> PersLit -> FactionId -> State -> FactionPers factionPerception fovMode persLit fid s = EM.mapWithKey (fidLidPerception 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 :: PerceptionReachable -> PointArray.Array Bool -> [Point] -> PerceptionVisible visibleOnLevel PerceptionReachable{preachable} litPs nocto = let isVisible = (litPs PointArray.!) 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 :: PointArray.Array Bool -> FovMode -> (Actor, FovCache3) -> PerceptionReachable reachableFromActor clearPs fovMode (body, FovCache3{fovSight}) = let radius = min (fromIntegral $ bcalm body `div` (5 * oneM)) fovSight in PerceptionReachable $ fullscan clearPs fovMode radius (bpos body) -- | Compute all dynamically lit positions on a level, whether lit by actors -- or 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). litByItems :: PointArray.Array Bool -> FovMode -> [(Point, Int)] -> PerceptionDynamicLit litByItems clearPs fovMode allItems = let litPos :: (Point, Int) -> [Point] litPos (p, light) = fullscan clearPs fovMode light p in PerceptionDynamicLit $ concatMap litPos allItems -- | Compute all lit positions in the dungeon. litInDungeon :: FovMode -> State -> StateServer -> PersLit litInDungeon fovMode s ser = let Kind.COps{cotile} = scops s processIid3 (FovCache3 sightAcc smellAcc lightAcc) (iid, (k, _)) = let FovCache3{..} = EM.findWithDefault emptyFovCache3 iid $ sItemFovCache ser in FovCache3 (k * fovSight + sightAcc) (k * fovSmell + smellAcc) (k * fovLight + lightAcc) processBag3 bag acc = foldl' processIid3 acc $ EM.assocs bag itemsInActors :: Level -> EM.EnumMap FactionId [(Actor, FovCache3)] itemsInActors lvl = let processActor aid = let b = getActorBody aid s sslOrgan = processBag3 (borgan b) emptyFovCache3 ssl = processBag3 (beqp b) sslOrgan in (bfid b, [(b, ssl)]) asLid = map processActor $ concat $ EM.elems $ lprio lvl in EM.fromListWith (++) asLid processIid lightAcc (iid, (k, _)) = let FovCache3{fovLight} = EM.findWithDefault emptyFovCache3 iid $ sItemFovCache ser in k * fovLight + lightAcc processBag bag acc = foldl' processIid acc $ EM.assocs bag lightOnFloor :: Level -> [(Point, Int)] lightOnFloor lvl = let processPos (p, bag) = (p, processBag bag 0) in map processPos $ EM.assocs $ lfloor lvl -- lembed are hidden -- 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). litOnLevel :: Level -> ( EM.EnumMap FactionId [(Actor, FovCache3)] , PointArray.Array Bool , PointArray.Array Bool ) litOnLevel lvl@Level{ltile} = let bodyMap = itemsInActors lvl allBodies = concat $ EM.elems bodyMap clearTiles = PointArray.mapA (Tile.isClear cotile) ltile blockFromBody (b, _) = if bproj b then Nothing else Just (bpos b, False) -- TODO: keep it in server state and update when tiles change -- and actors are born/move/die. Actually, do this for PersLit. blockingActors = mapMaybe blockFromBody allBodies clearPs = clearTiles PointArray.// blockingActors litTiles = PointArray.mapA (Tile.isLit cotile) ltile actorLights = map (\(b, FovCache3{fovLight}) -> (bpos b, fovLight)) allBodies floorLights = lightOnFloor lvl -- If there is light both on the floor and carried by actor, -- only the stronger light is taken into account. -- This is rare, so no point optimizing away the double computation. allLights = floorLights ++ actorLights litDynamic = pdynamicLit $ litByItems clearPs fovMode allLights litPs = litTiles PointArray.// map (\p -> (p, True)) litDynamic in (bodyMap, clearPs, litPs) 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 :: PointArray.Array Bool -- ^ the array with non-clear points -> FovMode -- ^ scanning mode -> Int -- ^ scanning radius -> Point -- ^ position of the spectator -> [Point] fullscan clearPs fovMode radius spectatorPos | radius <= 0 = [] | radius == 1 = [spectatorPos] | otherwise = 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 {-# INLINE isCl #-} isCl = (clearPs PointArray.!) -- 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] {-# INLINE tr8 #-} 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] {-# INLINE tr4 #-} 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 ] LambdaHack-0.5.0.0/Game/LambdaHack/Server/MonadServer.hs0000644000000000000000000002373412555256425020702 0ustar0000000000000000-- | 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 , debugPossiblyPrint, debugPossiblyPrintAndExit , serverPrint, 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.Exit (exitFailure) 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.ClientOptions 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)) debugPossiblyPrint :: MonadServer m => Text -> m () debugPossiblyPrint t = do debug <- getsServer $ sdbgMsgSer . sdebugSer when debug $ liftIO $ do T.hPutStrLn stderr t hFlush stderr debugPossiblyPrintAndExit :: MonadServer m => Text -> m () debugPossiblyPrintAndExit t = do debug <- getsServer $ sdbgMsgSer . sdebugSer when debug $ liftIO $ do T.hPutStrLn stderr t hFlush stderr exitFailure serverPrint :: MonadServer m => Text -> m () serverPrint t = 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 dictionary. Return the empty table if no file. restoreScore :: MonadServer m => Kind.COps -> m HighScore.ScoreDict 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 let !_A = assert (maybe True ((fid ==) . bfid) mbody) () 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. scoreDict <- restoreScore cops gameModeId <- getsState sgameModeId time <- getsState stime date <- liftIO getClockTime DebugModeSer{scurDiffSer} <- getsServer sdebugSer factionD <- getsState sfactionD bench <- getsServer $ sbenchmark . sdebugCli . sdebugSer let path = dataDir scoresFile outputScore (worthMentioning, (ntable, pos)) = -- If not human, probably debugging, so dump instead of registering. if bench || isAIFact fact then debugPossiblyPrint $ T.intercalate "\n" $ HighScore.showScore (pos, HighScore.getRecord pos ntable) else let nScoreDict = EM.insert gameModeId ntable scoreDict in when worthMentioning $ liftIO $ encodeEOF path (nScoreDict :: HighScore.ScoreDict) diff | fhasUI $ gplayer fact = scurDiffSer | otherwise = difficultyInverse scurDiffSer theirVic (fi, fa) | isAtWar fact fi && not (isHorrorFact 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 table = HighScore.getTable gameModeId scoreDict registeredScore = HighScore.register table total time status date diff (fname $ gplayer fact) ourVictims theirVictims (fhiCondPoly $ gplayer fact) 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 . sdebugCli . 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 debugPossiblyPrint $ "Session time:" <+> tshow diff <> "s." <+> "Average clips per second:" <+> tshow cps <> "." tellGameClipPS :: MonadServer m => m () tellGameClipPS = do bench <- getsServer $ sbenchmark . sdebugCli . 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 debugPossiblyPrint $ "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 bench = sbenchmark $ sdebugCli sdebugSer if bench then return Nothing else 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 LambdaHack-0.5.0.0/Game/LambdaHack/Server/EndServer.hs0000644000000000000000000000704112555256425020343 0ustar0000000000000000-- | The main loop of the server, processing human and computer player -- moves turn by turn. module Game.LambdaHack.Server.EndServer ( endOrLoop, dieSer ) 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.Content.ModeKind 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 () -> (Maybe (GroupName ModeKind) -> 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, stNewGame} -> stNewGame _ -> 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 swriteSave when bkpSave $ do modifyServer $ \ser -> ser {swriteSave = False} gameSave case (quitters, campers) of (gameMode : _, _) -> restart $ Just gameMode _ | gameOver -> restart Nothing ([], []) -> 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 = -- 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 dropAllItems aid b hit b2 <- getsState $ getActorBody aid execUpdAtomic $ UpdDestroyActor aid b2 [] else do discoKind <- getsServer sdiscoKind trunk <- getsState $ getItemBody $ btrunk b let ikind = discoKind EM.! jkindIx trunk execUpdAtomic $ UpdRecordKill aid ikind 1 electLeader (bfid b) (blid b) aid tb <- getsState $ getActorBody aid deduceKilled aid tb -- tb has items not dropped, stash in inv fact <- getsState $ (EM.! bfid b) . sfactionD -- Prevent faction's stash from being lost in case they are not spawners. -- Projectiles can't drop stash, because they are blind and so the faction -- would not see the actor that drops the stash, leading to a crash. -- But this is OK; projectiles can't be leaders, so stash dropped earlier. when (isNothing $ gleader fact) $ moveStores aid CSha CInv dropAllItems aid b False b2 <- getsState $ getActorBody aid execUpdAtomic $ UpdDestroyActor aid b2 [] -- | Drop all actor's items. dropAllItems :: (MonadAtomic m, MonadServer m) => ActorId -> Actor -> Bool -> m () dropAllItems aid b hit = do mapActorCStore_ CInv (dropCStoreItem CInv aid b hit) b mapActorCStore_ CEqp (dropCStoreItem CEqp aid b hit) b LambdaHack-0.5.0.0/Game/LambdaHack/Server/Fov/0000755000000000000000000000000012555256425016642 5ustar0000000000000000LambdaHack-0.5.0.0/Game/LambdaHack/Server/Fov/Common.hs0000644000000000000000000000530712555256425020433 0ustar0000000000000000-- | Common definitions for the Field of View algorithms. -- See -- 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 LambdaHack-0.5.0.0/Game/LambdaHack/Server/Fov/Permissive.hs0000644000000000000000000001464312555256425021334 0ustar0000000000000000-- | PFOV (Permissive Field of View) clean-room reimplemented based on the algorithm described in , -- 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) LambdaHack-0.5.0.0/Game/LambdaHack/Server/Fov/Digital.hs0000644000000000000000000001476312555256425020566 0ustar0000000000000000{-# LANGUAGE CPP #-} -- | DFOV (Digital Field of View) implemented according to specification at . -- This fast version of the algorithm, based on "PFOV", has AFAIK -- never been described nor implemented before. module Game.LambdaHack.Server.Fov.Digital ( scan #ifdef EXPOSE_INTERNAL -- * Internal operations , dline, dsteeper, intersect, _debugSteeper, _debugLine #endif ) 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] {-# INLINE scan #-} 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] {-# INLINE mscanVisible #-} mscanVisible s = go where go 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 = go (ps+1) -- continue in visible area where steepBump = B ps d gte :: Bump -> Bump -> Bool {-# INLINE gte #-} gte = dsteeper steepBump nep = maximal gte (snd s) 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 :: Bump -> Bump -> Bool {-# INLINE gte #-} 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 #ifdef WITH_EXPENSIVE_ASSERTIONS assert (uncurry blame $ _debugLine line) #endif 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 = #ifdef WITH_EXPENSIVE_ASSERTIONS assert (res == _debugSteeper f p1 p2) #endif 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 = #ifdef WITH_EXPENSIVE_ASSERTIONS assert (allB (>= 0) [y, yf]) #endif ((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) LambdaHack-0.5.0.0/Game/LambdaHack/Server/Fov/Shadow.hs0000644000000000000000000001165312555256425020431 0ustar0000000000000000-- | 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)) LambdaHack-0.5.0.0/Game/LambdaHack/Server/DungeonGen/0000755000000000000000000000000012555256425020141 5ustar0000000000000000LambdaHack-0.5.0.0/Game/LambdaHack/Server/DungeonGen/Cave.hs0000644000000000000000000002032712555256425021357 0ustar0000000000000000-- | Generation of caves (not yet inhabited dungeon levels) from cave kinds. module Game.LambdaHack.Server.DungeonGen.Cave ( Cave(..), buildCave ) where import Control.Applicative 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 (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) <- 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 Left <$> mkVoidRoom innerArea else Right <$> mkRoom minPlaceSize maxPlaceSize innerArea return (i, r')) gs fence <- buildFenceRnd cops couterFenceTile subFullArea dnight <- chanceDice ldepth totalDepth cnightChance darkCorTile <- fromMaybe (assert `failure` cdarkCorTile) <$> opick cdarkCorTile (const True) litCorTile <- 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 = connects `union` 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 -> if pfence (pokind qkind) `elem` [FFloor, FGround] then -- Avoid corridors touching the floor fence, -- but let them merge with the fence. case shrink sr of Nothing -> (sr, r) Just mergeArea -> (mergeArea, r) else (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 LambdaHack-0.5.0.0/Game/LambdaHack/Server/DungeonGen/Area.hs0000644000000000000000000000307712555256425021354 0ustar0000000000000000-- | 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) LambdaHack-0.5.0.0/Game/LambdaHack/Server/DungeonGen/Place.hs0000644000000000000000000002645712555256425021537 0ustar0000000000000000{-# LANGUAGE RankNTypes #-} -- | Generation of places from place kinds. module Game.LambdaHack.Server.DungeonGen.Place ( TileMapEM, Place(..), placeCheck, buildFenceRnd, buildPlace ) where import Control.Applicative 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 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 (TileKind) import qualified Game.LambdaHack.Content.TileKind as TK 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 :: !(GroupName TileKind) , qFWall :: !(Kind.Id TileKind) , qFFloor :: !(Kind.Id TileKind) , qFGround :: !(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 FGround -> 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 cops@Kind.COps{ cotile=Kind.Ops{opick=opick} , coplace=Kind.Ops{ofoldrGroup} } CaveKind{..} dnight darkCorTile litCorTile ldepth@(AbsDepth ld) totalDepth@(AbsDepth depth) r = do qFWall <- 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 fromIntegral ld * 10 <= x * fromIntegral depth then (x1y1, (x, y)) else findInterval (x, y) rest linearInterpolation dataset = -- We assume @dataset@ is sorted and between 0 and 10. let ((x1, y1), (x2, y2)) = findInterval (0, 0) dataset in ceiling $ fromIntegral y1 + fromIntegral (y2 - y1) * (fromIntegral ld * 10 - x1 * fromIntegral depth) / ((x2 - x1) * fromIntegral 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 (map fst checkedFreq)) checkedFreq let !_A = assert (not (nullFreq freq) `blame` (placeFreq, checkedFreq, r)) () ((qkind, kr), _) <- frequency freq let qFFloor = if dark then darkCorTile else litCorTile qFGround = if dnight 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 cops (poverride kr) legend <- olegend cops qlegend legendLit <- olegend cops clegendLitTile let xlegend = EM.union override legend xlegendLit = EM.union override legendLit cmap = tilePlace qarea kr fence = case pfence kr of FWall -> buildFence qFWall qarea FFloor -> buildFence qFFloor qarea FGround -> buildFence qFGround 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 = EM.findWithDefault (assert `failure` (qlegend, x)) 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.COps -> GroupName TileKind -> Rnd (EM.EnumMap Char (Kind.Id TileKind)) olegend Kind.COps{cotile=Kind.Ops{ofoldrWithKey, opick}} cgroup = let getSymbols _ tk acc = maybe acc (const $ ES.insert (TK.tsymbol tk) acc) (lookup cgroup $ TK.tfreq tk) symbols = ofoldrWithKey getSymbols ES.empty getLegend s acc = do m <- acc tk <- fmap (fromMaybe $ assert `failure` (cgroup, s)) $ opick cgroup $ (== s) . TK.tsymbol return $! EM.insert s tk m legend = ES.foldr getLegend (return EM.empty) symbols in legend ooverride :: Kind.COps -> [(Char, GroupName TileKind)] -> Rnd (EM.EnumMap Char (Kind.Id TileKind)) ooverride Kind.COps{cotile=Kind.Ops{opick}} poverride = let getLegend (s, cgroup) acc = do m <- acc tk <- 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 -> GroupName TileKind -> 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 <- 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) = map (`Point` y2) [x2..] 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 qFWall put qFFloor put qFGround get = do qkind <- get qarea <- get qseen <- get qlegend <- get qFWall <- get qFFloor <- get qFGround <- get return $! Place{..} LambdaHack-0.5.0.0/Game/LambdaHack/Server/DungeonGen/AreaRnd.hs0000644000000000000000000001672312555256425022022 0ustar0000000000000000-- | 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 let !_A = assert (xm <= x1 - x0 + 1 && ym <= y1 - y0 + 1) () 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 let !_A = assert (sx1 <= tx0 || sy1 <= ty0 `blame` (sa, ta)) () let !_A = assert (sx1 <= sox1 || sy1 <= soy1 `blame` (sa, so)) () let !_A = assert (tx0 >= tox0 || ty0 >= toy0 `blame` (ta, to)) () 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 LambdaHack-0.5.0.0/Game/LambdaHack/Client/0000755000000000000000000000000012555256425016060 5ustar0000000000000000LambdaHack-0.5.0.0/Game/LambdaHack/Client/UI.hs0000644000000000000000000001526512555256425016742 0ustar0000000000000000{-# LANGUAGE CPP #-} -- | 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 #ifdef EXPOSE_INTERNAL -- * Internal operations , humanCommand #endif ) where import Control.Exception.Assert.Sugar import Control.Monad import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES 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.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.StartupFrontendClient import Game.LambdaHack.Client.UI.WidgetClient import Game.LambdaHack.Common.Faction 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 import Game.LambdaHack.Content.ModeKind -- | Handle the move of a UI player. queryUI :: MonadClientUI m => m RequestUI queryUI = do side <- getsClient sside fact <- getsState $ (EM.! side) . sfactionD let (leader, mtgt) = fromMaybe (assert `failure` fact) $ gleader fact req <- humanCommand leader2 <- getLeaderUI mtgt2 <- getsClient $ fmap fst . EM.lookup leader2 . stargetD if (leader2, mtgt2) /= (leader, mtgt) then return $! ReqUILeader leader2 mtgt2 req else return $! req -- | Let the human player issue commands until any command takes time. humanCommand :: forall m. MonadClientUI m => m RequestUI humanCommand = do -- For human UI we invalidate whole @sbfsD@ at the start of each -- UI player input that start a player move, which is an overkill, -- but doesn't slow screensavers, because they are UI, -- but not human. modifyClient $ \cli -> cli {sbfsD = EM.empty, slastLost = ES.empty} let loop :: Either Bool (Maybe Bool, Overlay) -> m RequestUI loop mover = do (lastBlank, over) <- case mover of Left b -> do -- Display current state and keys if no slideshow or if interrupted. keys <- if b then describeMainKeys else return "" sli <- promptToSlideshow keys return (Nothing, head . snd $! slideshow sli) Right 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} lastPlay <- getsClient slastPlay km <- getKeyOverlayCommand lastBlank over -- Messages shown, so update history and reset current report. when (null lastPlay) recordHistory abortOrCmd <- do -- Look up the key. Binding{bcmdMap} <- askBinding case M.lookup km{K.pointer=Nothing} bcmdMap of Just (_, _, cmd) -> do -- Query and clear the last command key. modifyClient $ \cli -> cli {swaitTimes = if swaitTimes cli > 0 then - swaitTimes cli else 0} escAI <- getsClient sescAI case escAI of EscAIStarted -> do modifyClient $ \cli -> cli {sescAI = EscAIMenu} cmdHumanSem cmd EscAIMenu -> do unless (km `elem` [K.escKM, K.returnKM]) $ modifyClient $ \cli -> cli {sescAI = EscAIExited} cmdHumanSem cmd _ -> do modifyClient $ \cli -> cli {sescAI = EscAINothing} stgtMode <- getsClient stgtMode if km == K.escKM && isNothing stgtMode && isRight mover then cmdHumanSem Clear else cmdHumanSem cmd Nothing -> let msgKey = "unknown command <" <> K.showKM km <> ">" in failWith 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 [] -> do stgtMode <- getsClient stgtMode return $ Left $ isJust stgtMode || km == K.escKM [sLast] -> -- Avoid displaying the single slide twice. return $ Right (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 Right (onBlank, last sli) else Left True loop mLast loop $ Left False -- | 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 = isAIFact fact if escPressed && underAI && fleaderMode (gplayer fact) /= LeaderNull then do modifyClient $ \cli -> cli {sescAI = EscAIStarted} -- 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 [] LambdaHack-0.5.0.0/Game/LambdaHack/Client/LoopClient.hs0000644000000000000000000001103612555256425020465 0ustar0000000000000000{-# 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.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 -- | The main game loop for an AI client. 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 -- | The main game loop for a UI client. 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 <- getGameMode 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 (isAIFact 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 LambdaHack-0.5.0.0/Game/LambdaHack/Client/BfsClient.hs0000644000000000000000000004021412555256425020266 0ustar0000000000000000{-# LANGUAGE CPP, TupleSections #-} -- | Breadth first search and realted algorithms using the client monad. module Game.LambdaHack.Client.BfsClient ( invalidateBfs, getCacheBfsAndPath, getCacheBfs, accessCacheBfs , unexploredDepth, closestUnknown, closestSuspect, closestSmell, furthestKnown , closestTriggers, closestItems, closestFoes ) where import Control.Applicative 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 Game.LambdaHack.Common.Faction 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.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.Common.Vector import Game.LambdaHack.Content.TileKind (TileKind) invalidateBfs :: ActorId -> EM.EnumMap ActorId ( Bool, PointArray.Array BfsDistance , Point, Int, Maybe [Point]) -> EM.EnumMap ActorId ( Bool, PointArray.Array BfsDistance , Point, Int, Maybe [Point]) invalidateBfs = EM.adjust (\(_, bfs, target, seps, mpath) -> (False, bfs, target, seps, mpath)) -- | 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 b <- getsState $ getActorBody aid let origin = bpos b (isEnterable, passUnknown) <- condBFS aid let pathAndStore :: PointArray.Array BfsDistance -> m (PointArray.Array BfsDistance, Maybe [Point]) pathAndStore bfs = do let mpath = findPathBfs isEnterable passUnknown origin target seps bfs modifyClient $ \cli -> cli {sbfsD = EM.insert aid (True, bfs, target, seps, mpath) (sbfsD cli)} return (bfs, mpath) mbfs <- getsClient $ EM.lookup aid . sbfsD -- TODO: record past skills too, in case mobility lost; but no great harm, -- perhaps the loss is temporary case mbfs of Just (True, bfs, targetOld, sepsOld, mpath) -- TODO: hack: in screensavers this is not always ensured, so check here: | bfs PointArray.! bpos b == succ apartBfs -> if targetOld == target && sepsOld == seps then return (bfs, mpath) else pathAndStore bfs _ -> do -- Reduce the number of pointers to @bfsInvalid@, to help @safeSetA@. modifyClient $ \cli -> cli {sbfsD = EM.delete aid $ sbfsD cli} Level{lxsize, lysize} <- getLevel $ blid b let vInitial = case mbfs of Just (_, bfsInvalid, _, _, _) -> -- TODO: we should verify size -- We need to use the safe set, because previous values -- of the BFS array for the actor can be stuck unevaluated -- in thunks and we are not allowed to overwrite them. PointArray.safeSetA apartBfs bfsInvalid _ -> PointArray.replicateA lxsize lysize apartBfs bfs = fillBfs isEnterable passUnknown origin vInitial 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 (True, bfs, _, _, _) -> return bfs _ -> fst <$> getCacheBfsAndPath aid (Point 0 0) -- @undefined@ here crashes, because it's used to invalidate cache, -- but the paths is not computed, until needed (unlikely at (0, 0)) condBFS :: MonadClient m => ActorId -> m (Point -> Point -> MoveLegal, Point -> Point -> Bool) {-# INLINE condBFS #-} condBFS aid = do cops@Kind.COps{cotile=cotile@Kind.Ops{ouniqGroup}} <- getsState scops b <- getsState $ getActorBody aid -- We assume the actor eventually becomes a leader (or has the same -- set of abilities 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. activeItems <- activeItemsClient aid let actorMaxSk = sumSkills activeItems alterSkill = EM.findWithDefault 0 Ability.AbAlter actorMaxSk canSearchAndOpen = alterSkill >= 1 canMove = EM.findWithDefault 0 Ability.AbMove actorMaxSk > 0 || EM.findWithDefault 0 Ability.AbDisplace actorMaxSk > 0 -- TODO: needed for now, because AI targets enemies -- based on the path to them, not LOS to them. || EM.findWithDefault 0 Ability.AbProject actorMaxSk > 0 lvl <- getLevel $ blid b smarkSuspect <- getsClient smarkSuspect fact <- getsState $ (EM.! bfid b) . sfactionD let underAI = isAIFact fact enterSuspect = canSearchAndOpen && (smarkSuspect || underAI) isPassable | enterSuspect = Tile.isPassable | otherwise = Tile.isPassableNoSuspect -- 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 chDoorAccess = [checkDoorAccess cops lvl | canSearchAndOpen] conditions = catMaybes $ chAccess : chDoorAccess -- Legality of move from a known tile, assuming doors freely openable. isEnterable :: Point -> Point -> MoveLegal {-# INLINE isEnterable #-} 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 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 {-# INLINE passUnknown #-} 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 if canMove then return (isEnterable, passUnknown) else return (\_ _ -> MoveBlocked, \_ _ -> False) 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 $! assert (dist > apartBfs `blame` (aid, furthestPos, dist)) furthestPos -- | Closest reachable unknown tile position, if any. closestUnknown :: MonadClient m => ActorId -> m (Maybe Point) closestUnknown aid = do body <- getsState $ getActorBody aid lvl@Level{lxsize, lysize} <- getLevel $ blid body bfs <- getCacheBfs aid let closestPoss = PointArray.minIndexesA bfs dist = bfs PointArray.! head closestPoss if dist >= apartBfs then do when (lclear lvl == lseen lvl) $ do -- explored fully, mark it once for all let !_A = assert (lclear lvl >= lseen lvl) () modifyClient $ \cli -> cli {sexplored = ES.insert (blid body) (sexplored cli)} return Nothing else do let unknownAround p = let vic = vicinity lxsize lysize p posUnknown pos = bfs PointArray.! pos < apartBfs vicUnknown = filter posUnknown vic in length vicUnknown cmp = comparing unknownAround return $ Just $ maximumBy cmp closestPoss -- 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, ltime} <- getLevel $ blid body let smells = filter ((> ltime) . snd) $ 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 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. closestTriggers :: MonadClient m => Maybe Bool -> ActorId -> m (Frequency Point) closestTriggers onlyDir aid = do Kind.COps{cotile} <- getsState scops body <- getsState $ getActorBody aid explored <- getsClient sexplored let lid = blid body lvl <- getLevel lid dungeon <- getsState sdungeon let escape = any (not . null . lescape) $ EM.elems dungeon unexploredD <- unexploredDepth let allExplored = ES.size explored == EM.size dungeon -- If lid not explored, aid equips a weapon and so can leave level. lidExplored = ES.member (blid body) explored f :: [(Int, Point)] -> Point -> Kind.Id TileKind -> [(Int, Point)] f acc p t = if Tile.isWalkable cotile t && not (null $ Tile.causeEffects cotile t) then case Tile.ascendTo cotile t of [] -> -- Escape (or guard) only after exploring, for high score, etc. if isNothing onlyDir && allExplored then (9999999, p) : acc -- all from that level congregate here else acc l -> if not escape && allExplored -- Direction irrelevant; wander randomly. then map (,p) l ++ acc else let g k = let easier = signum k /= signum (fromEnum lid) unexpForth = unexploredD (signum k) lid unexpBack = unexploredD (- signum k) lid aiCond = if unexpForth then easier || not unexpBack && lidExplored else not unexpBack && lidExplored && null (lescape lvl) in maybe aiCond (\d -> d == (k > 0)) onlyDir in map (,p) (filter g l) ++ acc else acc 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, -- unless the actor has just returned via the very stairs. triggers = filter ((/= bpos body) . snd) triggersAll bfs <- getCacheBfs aid return $ case triggers of -- keep lazy [] -> mzero _ | isNothing onlyDir && not escape && allExplored -> -- Distance also irrelevant, to ensure random wandering. toFreq "closestTriggers when allExplored" triggers _ -> -- Prefer stairs to easier levels. -- If exactly one escape, these stairs will all be in one direction. let mix (k, p) dist = let easier = signum k /= signum (fromEnum lid) depthDelta = if easier then 2 else 1 maxd = fromEnum (maxBound :: BfsDistance) - fromEnum apartBfs v = (maxd * maxd * maxd) `div` ((dist + 1) * (dist + 1)) in (depthDelta * v, p) ds = mapMaybe (\(k, p) -> mix (k, p) <$> accessBfs bfs p) triggers in toFreq "closestTriggers" 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 && not (null $ 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 = 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 LambdaHack-0.5.0.0/Game/LambdaHack/Client/HandleResponseClient.hs0000644000000000000000000000371412555256425022472 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} -- | Semantics of client commands. module Game.LambdaHack.Client.HandleResponseClient ( handleResponseAI, handleResponseUI ) where 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 (return ()) (\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 LambdaHack-0.5.0.0/Game/LambdaHack/Client/State.hs0000644000000000000000000002404112555256425017475 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | Server and client game state types and operations. module Game.LambdaHack.Client.State ( StateClient(..), defStateClient, defaultHistory , updateTarget, getTarget, updateLeader, sside , PathEtc, TgtMode(..), RunParams(..), LastRecord, EscAI(..) , toggleMarkVision, toggleMarkSmell, toggleMarkSuspect ) where import Control.Exception.Assert.Sugar import Data.Binary import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES import Data.Text (Text) import qualified Data.Text as T import 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.Misc 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 ( Bool, 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 , sdiscoKind :: !DiscoveryKind -- ^ remembered item discoveries , sdiscoEffect :: !DiscoveryEffect -- ^ remembered effects&Co of items , sfper :: !FactionPers -- ^ faction perception indexed by levels , srandom :: !R.StdGen -- ^ current random generator , slastKM :: !K.KM -- ^ last issued key command , slastRecord :: !LastRecord -- ^ state of key sequence recording , slastPlay :: ![K.KM] -- ^ state of key sequence playback , slastLost :: !(ES.EnumSet ActorId) -- ^ actors that just got out of sight , 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 , scurDiff :: !Int -- ^ current game difficulty level , snxtDiff :: !Int -- ^ next game difficulty level , sslots :: !ItemSlots -- ^ map from slots to items , slastSlot :: !SlotChar -- ^ last used slot , slastStore :: !CStore -- ^ last used store , sescAI :: !EscAI -- ^ just canceled AI control with ESC , 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) -- | 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) 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 ) data EscAI = EscAINothing | EscAIStarted | EscAIMenu | EscAIExited deriving (Show, Eq) -- | 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 = [] , sdiscoKind = EM.empty , sdiscoEffect = EM.empty , sfper = EM.empty , srandom = R.mkStdGen 42 -- will be set later , slastKM = K.escKM , slastRecord = ([], [], 0) , slastPlay = [] , slastLost = ES.empty , swaitTimes = 0 , _sleader = Nothing -- no heroes yet alive , _sside , squit = False , sisAI , smarkVision = False , smarkSmell = True , smarkSuspect = False , scurDiff = difficultyDefault , snxtDiff = difficultyDefault , sslots = (EM.empty, EM.empty) , slastSlot = SlotChar 0 'Z' , slastStore = CInv , sescAI = EscAINothing , sdebugCli = defDebugModeCli } defaultHistory :: Int -> IO History defaultHistory configHistoryMax = do dateTime <- getClockTime let curDate = MU.Text $ T.pack $ calendarTimeToString $ toUTCTime dateTime let emptyHist = emptyHistory configHistoryMax return $! addReport emptyHist timeZero $! 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 sdiscoKind put sdiscoEffect put (show srandom) put _sleader put _sside put sisAI put smarkVision put smarkSmell put smarkSuspect put scurDiff put snxtDiff put sslots put slastSlot put slastStore 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 sdiscoKind <- get sdiscoEffect <- get g <- get _sleader <- get _sside <- get sisAI <- get smarkVision <- get smarkSmell <- get smarkSuspect <- get scurDiff <- get snxtDiff <- get sslots <- get slastSlot <- get slastStore <- get sdebugCli <- get let sbfsD = EM.empty sfper = EM.empty srandom = read g slastKM = K.escKM slastRecord = ([], [], 0) slastPlay = [] slastLost = ES.empty swaitTimes = 0 squit = False sescAI = EscAINothing return $! StateClient{..} 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{..} LambdaHack-0.5.0.0/Game/LambdaHack/Client/Key.hs0000644000000000000000000002172412555256425017152 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} -- | Frontend-independent keyboard input operations. module Game.LambdaHack.Client.Key ( Key(..), showKey, handleDir, dirAllKey , moveBinding, mkKM, keyTranslate , Modifier(..), KM(..), toKM, showKM , escKM, spaceKM, returnKM, pgupKM, pgdnKM, leftButtonKM, rightButtonKM ) where import Control.DeepSeq 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.Point 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 | Home | KP !Char -- ^ a keypad key for a character (digits and operators) | Char !Char -- ^ a single printable character | LeftButtonPress -- ^ left mouse button pressed | MiddleButtonPress -- ^ middle mouse button pressed | RightButtonPress -- ^ right mouse button pressed | Unknown !Text -- ^ an unknown key, registered to warn the user deriving (Read, Ord, Eq, Generic) instance Binary Key instance NFData Key -- | Our own encoding of modifiers. Incomplete. data Modifier = NoModifier | Shift | Control | Alt deriving (Read, Ord, Eq, Generic) instance Binary Modifier instance NFData Modifier data KM = KM { key :: !Key , modifier :: !Modifier , pointer :: !(Maybe Point) } deriving (Read, Ord, Eq, Generic) instance NFData KM instance Show KM where show = T.unpack . showKM instance Binary KM toKM :: Modifier -> Key -> KM toKM modifier key = KM{pointer=Nothing, ..} -- Common and terse names for keys. showKey :: Key -> Text 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 Insert = "INSERT" showKey Delete = "DELETE" showKey (KP c) = "KEYPAD_" <> T.singleton c showKey (Char c) = T.singleton c showKey LeftButtonPress = "LEFT-BUTTON" showKey MiddleButtonPress = "MIDDLE-BUTTON" showKey RightButtonPress = "RIGHT-BUTTON" showKey (Unknown s) = s -- | Show a key with a modifier, if any. showKM :: KM -> Text showKM KM{modifier=Shift, key} = "SHIFT-" <> showKey key showKM KM{modifier=Control, key} = "CTRL-" <> showKey key showKM KM{modifier=Alt, key} = "ALT-" <> showKey key showKM KM{modifier=NoModifier, key} = showKey key escKM :: KM escKM = toKM NoModifier Esc spaceKM :: KM spaceKM = toKM NoModifier Space returnKM :: KM returnKM = toKM NoModifier Return pgupKM :: KM pgupKM = toKM NoModifier PgUp pgdnKM :: KM pgdnKM = toKM NoModifier PgDn leftButtonKM :: KM leftButtonKM = toKM NoModifier LeftButtonPress rightButtonKM :: KM rightButtonKM = toKM NoModifier RightButtonPress 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 dirMoveNoModifier :: Bool -> Bool -> [Key] dirMoveNoModifier configVi configLaptop = dirKeypadKey ++ if configVi then dirViKey else if configLaptop then dirLaptopKey else [] dirRunNoModifier :: Bool -> Bool -> [Key] dirRunNoModifier configVi configLaptop = dirKeypadShiftKey ++ if configVi then dirViShiftKey else if configLaptop then dirLaptopShiftKey else [] dirRunControl :: [Key] dirRunControl = dirKeypadKey ++ dirKeypadShiftKey ++ map Char dirKeypadShiftChar dirRunShift :: [Key] dirRunShift = dirRunControl dirAllKey :: Bool -> Bool -> [Key] dirAllKey configVi configLaptop = dirMoveNoModifier configVi configLaptop ++ dirRunNoModifier configVi configLaptop ++ dirRunControl -- | 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) $ cycle 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 (map (toKM modifier) keys) $ cycle moves) mapRun modifier keys = map (assign run) (zip (map (toKM modifier) keys) $ cycle moves) in mapMove NoModifier (dirMoveNoModifier configVi configLaptop) ++ mapRun NoModifier (dirRunNoModifier configVi configLaptop) ++ mapRun Control dirRunControl ++ mapRun Shift dirRunShift 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 ('S':'H':'I':'F':'T':'-':rest) -> toKM Shift (mkKey rest) ('C':'T':'R':'L':'-':rest) -> toKM Control (mkKey rest) ('A':'L':'T':'-':rest) -> toKM Alt (mkKey rest) _ -> toKM NoModifier (mkKey s) -- | 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" = KP '/' keyTranslate "bar" = 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 "at" = Char '@' keyTranslate "asciitilde" = Char '~' keyTranslate "exclam" = 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 "Up" = Up keyTranslate "KP_Up" = Up keyTranslate "Down" = Down keyTranslate "KP_Down" = Down keyTranslate "Left" = Left keyTranslate "KP_Left" = Left keyTranslate "Right" = Right keyTranslate "KP_Right" = Right keyTranslate "Home" = Home keyTranslate "KP_Home" = Home keyTranslate "End" = End keyTranslate "KP_End" = End keyTranslate "Page_Up" = PgUp keyTranslate "KP_Page_Up" = PgUp keyTranslate "Prior" = PgUp keyTranslate "KP_Prior" = PgUp keyTranslate "Page_Down" = PgDn keyTranslate "KP_Page_Down" = PgDn keyTranslate "Next" = PgDn keyTranslate "KP_Next" = PgDn 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 "KP_Insert" = Insert keyTranslate "Delete" = Delete keyTranslate "KP_Delete" = Delete keyTranslate "KP_Enter" = Return keyTranslate "LeftButtonPress" = LeftButtonPress keyTranslate "MiddleButtonPress" = MiddleButtonPress keyTranslate "RightButtonPress" = RightButtonPress keyTranslate ['K','P','_',c] = KP c keyTranslate [c] = Char c keyTranslate s = Unknown $ T.pack s LambdaHack-0.5.0.0/Game/LambdaHack/Client/MonadClient.hs0000644000000000000000000000713312555256425020615 0ustar0000000000000000-- | 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 bench <- getsClient $ sbenchmark . sdebugCli if bench then return Nothing else 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 LambdaHack-0.5.0.0/Game/LambdaHack/Client/Bfs.hs0000644000000000000000000001647012555256425017136 0ustar0000000000000000{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-} -- | Breadth first search algorithms. module Game.LambdaHack.Client.Bfs ( BfsDistance, MoveLegal(..), apartBfs , fillBfs, findPathBfs, accessBfs #ifdef EXPOSE_INTERNAL -- * Internal operations , minKnownBfs #endif ) where import Control.Exception.Assert.Sugar import Data.Binary import Data.Bits (Bits, complement, (.&.), (.|.)) import Data.List import Data.Maybe 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. -- The next value is the minimal distance value assigned to paths -- that don't enter any unknown tiles. apartBfs :: BfsDistance apartBfs = pred minKnownBfs -- TODO: costly; use a ring buffer instead of the lists, don't call so often -- | Fill out the given BFS array. -- Unsafe @PointArray@ 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. 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 {-# INLINE fillBfs #-} fillBfs isEnterable passUnknown origin aInitial = let maxKnownBfs = pred maxBound predMaxKnownBfs = pred maxKnownBfs bfs :: BfsDistance -> [Point] -> [Point] -> PointArray.Array BfsDistance -> PointArray.Array BfsDistance bfs distance predK predU a = let distCompl = distance .&. complement minKnownBfs processKnown (succK2, succU2, a2) pos = let fKnown (lK, lU) move = let p = shift pos move freshMv = a2 PointArray.! p == apartBfs legality = isEnterable pos p (notBlocked, enteredUnknown) = case legality of MoveBlocked -> (False, undefined) MoveToOpen -> (True, False) MoveToUnknown -> (True, True) in if freshMv && notBlocked then if enteredUnknown then (lK, p : lU) else (p : lK, lU) else (lK, lU) (mvsK, mvsU) = foldl' fKnown ([], []) moves upd = zip mvsK (repeat distance) ++ zip mvsU (repeat distCompl) !a3 = PointArray.unsafeUpdateA a2 upd in (mvsK ++ succK2, mvsU ++ succU2, a3) processUnknown (succU2, a2) pos = let fUnknown lU move = let p = shift pos move freshMv = a2 PointArray.! p == apartBfs notBlocked = passUnknown pos p in if freshMv && notBlocked then p : lU else lU mvsU = foldl' fUnknown [] moves upd = zip mvsU (repeat distCompl) !a3 = PointArray.unsafeUpdateA a2 upd in (mvsU ++ succU2, a3) (succU4, !a4) = foldl' processUnknown ([], a) predU (succK6, succU6, !a6) = foldl' processKnown ([], succU4, a4) predK in if null succK6 && null succU6 -- no more dungeon positions to check || distance == predMaxKnownBfs -- wasting one Known slot then a6 -- too far else bfs (succ distance) succK6 succU6 a6 in bfs (succ minKnownBfs) [origin] [] (PointArray.unsafeUpdateA aInitial [(origin, minKnownBfs)]) -- 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] {-# INLINE findPathBfs #-} 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 LambdaHack-0.5.0.0/Game/LambdaHack/Client/CommonClient.hs0000644000000000000000000002670712555256425021017 0ustar0000000000000000{-# 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 ) where import Control.Applicative import Control.Exception.Assert.Sugar import Control.Monad import qualified Data.EnumMap.Strict as EM import Data.Maybe 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 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.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 Game.LambdaHack.Common.Vector import qualified Game.LambdaHack.Content.ItemKind as IK -- | Get the current perception of a client. getPerFid :: MonadClient m => LevelId -> m Perception getPerFid lid = do fper <- getsClient sfper let assFail = assert `failure` "no perception at given level" `twith` (lid, fper) return $! EM.findWithDefault assFail 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 Msg Int) aidTgtAims aid lidV tgt = do let findNewEps onlyFirst pos = do oldEps <- getsClient seps b <- getsState $ getActorBody aid mnewEps <- makeLine onlyFirst b pos oldEps case mnewEps of Just newEps -> return $ Right newEps Nothing -> return $ Left $ if onlyFirst then "aiming blocked at the first step" else "aiming line to the opponent blocked somewhere" case tgt of Just (TEnemy a _) -> do body <- getsState $ getActorBody a let pos = bpos body if blid body == lidV then findNewEps False pos else return $ Left "selected opponent not on this level" Just TEnemyPos{} -> return $ Left "selected opponent not visible" Just (TPoint lid pos) -> if lid == lidV then findNewEps True pos else return $ Left "selected position not on this level" Just (TVector v) -> do b <- getsState $ getActorBody aid Level{lxsize, lysize} <- getLevel lidV let shifted = shiftBounded lxsize lysize (bpos b) v if shifted == bpos b && v /= Vector 0 0 then return $ Left "selected translation is void" else findNewEps True shifted 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 => Bool -> Actor -> Point -> Int -> m (Maybe Int) makeLine onlyFirst 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 accessFirst | not onlyFirst = False | otherwise = all noActor (take 1 blDist) && all (uncurry $ accessibleUnknown cops lvl) (take 1 blZip) nUnknown = length $ filter ((== unknownId) . (lvl `at`)) blDist in if accessU then - nUnknown else if accessFirst then -10000 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 <= 0 then Nothing -- ProjectAimOnself else if calcScore epsOld > minBound then Just epsOld -- keep old else tryLines (epsOld + 1) (Nothing, minBound) -- generate best actorSkillsClient :: MonadClient m => ActorId -> m Ability.Skills actorSkillsClient aid = do activeItems <- activeItemsClient aid body <- getsState $ getActorBody aid fact <- getsState $ (EM.! bfid body) . sfactionD side <- getsClient sside -- Newest Leader in _sleader, not yet in sfactionD. mleader1 <- if side == bfid body then getsClient _sleader else return Nothing let mleader2 = fst <$> gleader fact mleader = mleader1 `mplus` mleader2 getsState $ actorSkills mleader aid activeItems updateItemSlot :: MonadClient m => CStore -> Maybe ActorId -> ItemId -> m SlotChar updateItemSlot store maid iid = do slots@(itemSlots, organSlots) <- getsClient sslots let onlyOrgans = store == COrgan lSlots = if onlyOrgans then organSlots else itemSlots incrementPrefix m l iid2 = EM.insert l iid2 $ case EM.lookup l m of Nothing -> m Just iidOld -> let lNew = SlotChar (slotPrefix l + 1) (slotChar l) in incrementPrefix m lNew iidOld case lookup iid $ map swap $ EM.assocs lSlots of Nothing -> do side <- getsClient sside item <- getsState $ getItemBody iid lastSlot <- getsClient slastSlot mb <- maybe (return Nothing) (fmap Just . getsState . getActorBody) maid l <- getsState $ assignSlot store item side mb slots lastSlot let newSlots | onlyOrgans = ( itemSlots , incrementPrefix organSlots l iid ) | otherwise = ( incrementPrefix itemSlots l iid , organSlots ) modifyClient $ \cli -> cli {sslots = newSlots} return l Just l -> return l -- slot already assigned; a letter or a number fullAssocsClient :: MonadClient m => ActorId -> [CStore] -> m [(ItemId, ItemFull)] fullAssocsClient aid cstores = do cops <- getsState scops discoKind <- getsClient sdiscoKind discoEffect <- getsClient sdiscoEffect getsState $ fullAssocs cops discoKind discoEffect 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 -> ItemQuant -> ItemFull) itemToFullClient = do cops <- getsState scops discoKind <- getsClient sdiscoKind discoEffect <- getsClient sdiscoEffect s <- getState let itemToF iid = itemToFull cops discoKind discoEffect 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 (Maybe (RequestTimed 'Ability.AbMelee)) pickWeaponClient source target = do eqpAssocs <- fullAssocsClient source [CEqp] bodyAssocs <- fullAssocsClient source [COrgan] actorSk <- actorSkillsClient source sb <- getsState $ getActorBody source localTime <- getsState $ getLocalTime (blid sb) let allAssocs = eqpAssocs ++ bodyAssocs calm10 = calmEnough10 sb $ map snd allAssocs forced = assert (not $ bproj sb) False permitted = permittedPrecious calm10 forced preferredPrecious = either (const False) id . permitted strongest = strongestMelee True localTime allAssocs strongestPreferred = filter (preferredPrecious . snd . snd) strongest case strongestPreferred of _ | EM.findWithDefault 0 Ability.AbMelee actorSk <= 0 -> return Nothing [] -> return Nothing iis@((maxS, _) : _) -> do let maxIis = map snd $ takeWhile ((== maxS) . fst) iis (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 $ Just $ ReqMelee target iid cstore sumOrganEqpClient :: MonadClient m => IK.EqpSlot -> ActorId -> m Int sumOrganEqpClient eqpSlot aid = do activeItems <- activeItemsClient aid return $! sumSlotNoFilter eqpSlot activeItems LambdaHack-0.5.0.0/Game/LambdaHack/Client/ItemSlot.hs0000644000000000000000000000734412555256425020164 0ustar0000000000000000-- | Item slots for UI and AI item collections. -- TODO: document module Game.LambdaHack.Client.ItemSlot ( ItemSlots, SlotChar(..) , allSlots, slotLabel, slotRange, assignSlot ) where import Control.Exception.Assert.Sugar import Data.Binary import Data.Bits (shiftL, shiftR) import Data.Char import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES import Data.List import Data.Monoid import Data.Ord (comparing) 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.Misc import Game.LambdaHack.Common.State data SlotChar = SlotChar {slotPrefix :: Int, slotChar :: Char} deriving (Show, Eq) instance Ord SlotChar where compare = comparing fromEnum instance Binary SlotChar where put = put . fromEnum get = fmap toEnum get instance Enum SlotChar where fromEnum (SlotChar n c) = ord c + (if isUpper c then 100 else 0) + shiftL n 8 toEnum e = let n = shiftR e 8 c0 = e - shiftL n 8 c100 = c0 - if c0 > 150 then 100 else 0 in SlotChar n (chr c100) type ItemSlots = ( EM.EnumMap SlotChar ItemId , EM.EnumMap SlotChar ItemId ) slotRange :: [SlotChar] -> Text slotRange ls = sectionBy (sort ls) Nothing where succSlot c d = ord (slotChar d) - ord (slotChar c) == 1 succ2Slot c d = ord (slotChar d) - ord (slotChar c) == 2 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] | succ2Slot c d = T.pack [ slotChar c , chr (1 + ord (slotChar c)) , slotChar d ] | otherwise = T.pack [slotChar c, '-', slotChar d] allSlots :: Int -> [SlotChar] allSlots n = map (SlotChar n) $ ['a'..'z'] ++ ['A'..'Z'] allZeroSlots :: [SlotChar] allZeroSlots = allSlots 0 -- | 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 :: CStore -> Item -> FactionId -> Maybe Actor -> ItemSlots -> SlotChar -> State -> SlotChar assignSlot store item fid mbody (itemSlots, organSlots) lastSlot s = assert (maybe True (\b -> bfid b == fid) mbody) $ if jsymbol item == '$' then SlotChar 0 '$' else head $ fresh ++ free where offset = maybe 0 (+1) (elemIndex lastSlot allZeroSlots) onlyOrgans = store == COrgan len0 = length allZeroSlots candidatesZero = take len0 $ drop offset $ cycle allZeroSlots candidates = candidatesZero ++ concat [allSlots n | n <- [1..]] onPerson = sharedAllOwnedFid onlyOrgans fid s onGround = maybe EM.empty -- consider floor only under the acting actor (\b -> getCBag (CFloor (blid b) (bpos b)) s) mbody inBags = ES.unions $ map EM.keysSet $ onPerson : [ onGround | not onlyOrgans] lSlots = if onlyOrgans then organSlots else itemSlots f l = maybe True (`ES.notMember` inBags) $ EM.lookup l lSlots free = filter f candidates g l = l `EM.notMember` lSlots fresh = filter g $ take ((slotPrefix lastSlot + 1) * len0) candidates slotLabel :: SlotChar -> MU.Part slotLabel x = MU.String $ (if slotPrefix x == 0 then [] else show $ slotPrefix x) ++ [slotChar x] LambdaHack-0.5.0.0/Game/LambdaHack/Client/HandleAtomicClient.hs0000644000000000000000000004103312555256425022104 0ustar0000000000000000{-# LANGUAGE TupleSections #-} -- | Handle atomic commands received by the client. module Game.LambdaHack.Client.HandleAtomicClient ( cmdAtomicSemCli, cmdAtomicFilterCli ) 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.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.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.State import qualified Game.LambdaHack.Common.Tile as Tile import Game.LambdaHack.Content.ItemKind (ItemKind) import qualified Game.LambdaHack.Content.TileKind as TK -- * 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 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 $ TK.tname $ okind t , "at position", MU.Text $ tshow p , "suddenly" -- adverb , MU.SubjectVerbSg subject verb , MU.AW $ MU.Text $ TK.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 assert (t == toTile `blame` "LoseTile fails to reset memory" `twith` (aid, p, fromTile, toTile, b, t, cmd)) [cmd] -- Already knows the tile fully, only confirm. UpdLearnSecrets aid fromS _toS -> do b <- getsState $ getActorBody aid lvl <- getLevel $ blid b return $! [cmd | lsecret lvl == fromS] -- secrets not 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] UpdDiscover c iid _ seed ldepth -> do itemD <- getsState sitemD case EM.lookup iid itemD of Nothing -> return [] Just item -> do discoKind <- getsClient sdiscoKind if jkindIx item `EM.member` discoKind then do discoEffect <- getsClient sdiscoEffect if iid `EM.member` discoEffect then return [] else return [UpdDiscoverSeed c iid seed ldepth] else return [cmd] UpdCover c iid ik _ _ -> do itemD <- getsState sitemD case EM.lookup iid itemD of Nothing -> return [] Just item -> do discoKind <- getsClient sdiscoKind if jkindIx item `EM.notMember` discoKind then return [] else do discoEffect <- getsClient sdiscoEffect if iid `EM.notMember` discoEffect then return [cmd] else return [UpdCoverKind c iid ik] UpdDiscoverKind _ iid _ -> do itemD <- getsState sitemD case EM.lookup iid itemD of Nothing -> return [] Just item -> do discoKind <- getsClient sdiscoKind if jkindIx item `EM.notMember` discoKind then return [] else return [cmd] UpdCoverKind _ iid _ -> do itemD <- getsState sitemD case EM.lookup iid itemD of Nothing -> return [] Just item -> do discoKind <- getsClient sdiscoKind if jkindIx item `EM.notMember` discoKind then return [] else return [cmd] UpdDiscoverSeed _ iid _ _ -> do itemD <- getsState sitemD case EM.lookup iid itemD of Nothing -> return [] Just item -> do discoKind <- getsClient sdiscoKind if jkindIx item `EM.notMember` discoKind then return [] else do discoEffect <- getsClient sdiscoEffect if iid `EM.member` discoEffect then return [] else return [cmd] UpdCoverSeed _ iid _ _ -> do itemD <- getsState sitemD case EM.lookup iid itemD of Nothing -> return [] Just item -> do discoKind <- getsClient sdiscoKind if jkindIx item `EM.notMember` discoKind then return [] else do discoEffect <- getsClient sdiscoEffect if iid `EM.notMember` discoEffect 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 carriedAssocs <- getsState $ flip getCarriedAssocs fid <- getsClient sside s <- getState -- Wipe out actors that just became invisible due to changed FOV. -- Worst case is many actors O(n) in an open room of large diameter O(m). -- Then a step reveals many positions. Iterating over them via @posToActors@ -- takes O(m * n) and so is more cosly than interating over all actors -- and for each checking inclusion in a set of positions O(n * log m). -- OTOH, m is bounded by sight radius and n is unbounded, so we have -- O(n) in both cases, especially with huge levels. To help there, -- we'd need to keep a dictionary from positions to actors, which means -- @posToActors@ is the right approach for now. let seenNew = seenAtomicCli False fid perNew seenOld = seenAtomicCli False fid perOld outFov = totalVisible perOld ES.\\ totalVisible perNew outPrio = concatMap (\p -> posToActors p lid s) $ ES.elems outFov fActor (aid, b) = let ps = posProjBody b -- Verify that we forget only previously seen actors. !_A = assert (seenOld ps) () in -- We forget only currently invisible actors. if seenNew ps then Nothing else -- Verify that we forget only previously seen actors. let !_A = assert (seenOld ps) () ais = carriedAssocs b in Just $ UpdLoseActor aid b ais outActor = mapMaybe fActor outPrio -- Wipe out remembered items on tiles that now came into view. lvl <- getLevel lid let inFov = ES.elems $ totalVisible perNew ES.\\ totalVisible perOld pMaybe p = maybe Nothing (\x -> Just (p, x)) inContainer fc itemFloor = let inItem = mapMaybe (\p -> pMaybe p $ EM.lookup p itemFloor) inFov fItem p (iid, kit) = UpdLoseItem iid (getItemBody iid s) kit (fc lid p) fBag (p, bag) = map (fItem p) $ EM.assocs bag in concatMap fBag inItem inFloor = inContainer CFloor (lfloor lvl) inEmbed = inContainer CEmbed (lembed lvl) -- 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 lvl)) (ES.elems inSmellFov) inSmell = if null inSm then [] else [UpdLoseSmell lid inSm] let inTileSmell = inFloor ++ inEmbed ++ inSmell psItemSmell <- mapM posUpdAtomic inTileSmell -- Verify that we forget only previously invisible items and smell. let !_A = assert (allB (not . seenOld) psItemSmell) () -- Verify that we forget only currently seen items and smell. let !_A = assert (allB seenNew psItemSmell) () return $! cmd : outActor ++ inTileSmell _ -> return [cmd] -- | 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 let !_A = assert (mleader == fmap fst source -- somebody changed the leader for us || mleader == fmap fst target -- we changed the leader ourselves `blame` "unexpected leader" `twith` (cmd, mleader)) () modifyClient $ \cli -> cli {_sleader = fmap fst target} case target of Nothing -> return () Just (aid, mtgt) -> modifyClient $ \cli -> cli {stargetD = EM.alter (const $ (,Nothing) <$> mtgt) aid (stargetD cli)} UpdAutoFaction{} -> 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 -> cli { stargetD = case (mtgt, mleader) of (Just tgt, Just leader) -> EM.singleton leader tgt _ -> EM.empty } UpdDiscover c iid ik seed ldepth -> do discoverKind c iid ik discoverSeed c iid seed ldepth UpdCover c iid ik seed _ldepth -> do coverSeed c iid seed coverKind c iid ik UpdDiscoverKind c iid ik -> discoverKind c iid ik UpdCoverKind c iid ik -> coverKind c iid ik UpdDiscoverSeed c iid seed ldepth -> discoverSeed c iid seed ldepth UpdCoverSeed c iid seed _ldepth -> coverSeed c iid seed UpdPerception lid outPer inPer -> perception lid outPer inPer UpdRestart side sdiscoKind sfper _ d sdebugCli -> do shistory <- getsClient shistory sreport <- getsClient sreport isAI <- getsClient sisAI snxtDiff <- getsClient snxtDiff let cli = defStateClient shistory sreport side isAI putClient cli { sdiscoKind , sfper -- , sundo = [UpdAtomic cmd] , scurDiff = d , snxtDiff , sdebugCli } UpdResume _fid sfper -> modifyClient $ \cli -> cli {sfper} UpdKillExit _fid -> killExit UpdWriteSave -> 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 heed @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 => Container -> ItemId -> Kind.Id ItemKind -> m () discoverKind c iid ik = do item <- getsState $ getItemBody iid let f Nothing = Just ik f Just{} = assert `failure` "already discovered" `twith` (c, iid, ik) modifyClient $ \cli -> cli {sdiscoKind = EM.alter f (jkindIx item) (sdiscoKind cli)} coverKind :: MonadClient m => Container -> ItemId -> Kind.Id ItemKind -> m () coverKind c iid ik = do item <- getsState $ getItemBody iid let f Nothing = assert `failure` "already covered" `twith` (c, iid, ik) f (Just ik2) = assert (ik == ik2 `blame` "unexpected covered item kind" `twith` (ik, ik2)) Nothing modifyClient $ \cli -> cli {sdiscoKind = EM.alter f (jkindIx item) (sdiscoKind cli)} discoverSeed :: MonadClient m => Container -> ItemId -> ItemSeed -> AbsDepth -> m () discoverSeed c iid seed ldepth = do Kind.COps{coitem=Kind.Ops{okind}} <- getsState scops discoKind <- getsClient sdiscoKind item <- getsState $ getItemBody iid totalDepth <- getsState stotalDepth case EM.lookup (jkindIx item) discoKind of Nothing -> assert `failure` "kind not known" `twith` (c, iid, seed) Just ik -> do let kind = okind ik f Nothing = Just $ seedToAspectsEffects seed kind ldepth totalDepth f Just{} = assert `failure` "already discovered" `twith` (c, iid, seed) modifyClient $ \cli -> cli {sdiscoEffect = EM.alter f iid (sdiscoEffect cli)} coverSeed :: MonadClient m => Container -> ItemId -> ItemSeed -> m () coverSeed c iid seed = do let f Nothing = assert `failure` "already covered" `twith` (c, iid, seed) f Just{} = Nothing -- checking that old and new agree is too much work modifyClient $ \cli -> cli {sdiscoEffect = EM.alter f iid (sdiscoEffect cli)} killExit :: MonadClient m => m () killExit = modifyClient $ \cli -> cli {squit = True} LambdaHack-0.5.0.0/Game/LambdaHack/Client/AI.hs0000644000000000000000000001015012555256425016702 0ustar0000000000000000{-# LANGUAGE CPP #-} -- | 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, pongAI #ifdef EXPOSE_INTERNAL -- * Internal operations , refreshTarget, pickAction #endif ) 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.Faction import Game.LambdaHack.Common.Frequency import Game.LambdaHack.Common.MonadStateRead import Game.LambdaHack.Common.Msg import Game.LambdaHack.Common.Random import Game.LambdaHack.Common.Request import Game.LambdaHack.Common.State -- | Handle the move of an AI player. queryAI :: MonadClient m => ActorId -> m RequestAI queryAI oldAid = do side <- getsClient sside fact <- getsState $ (EM.! side) . sfactionD let mleader = gleader fact wasLeader = fmap fst mleader == Just oldAid (aidToMove, bToMove) <- pickActorToMove refreshTarget oldAid RequestAnyAbility reqAny <- pickAction (aidToMove, bToMove) let req = ReqAITimed reqAny mtgt2 <- getsClient $ fmap fst . EM.lookup aidToMove . stargetD if wasLeader && mleader /= Just (aidToMove, mtgt2) then return $! ReqAILeader aidToMove mtgt2 req else return $! req -- | Client signals to the server that it's still online. pongAI :: MonadClient m => m RequestAI pongAI = return ReqAIPong -- | 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) -- ^ the actor to refresh -> m (Maybe (Target, PathEtc)) refreshTarget (aid, body) = do side <- getsClient sside let !_A = assert (bfid body == side `blame` "AI tries to move an enemy actor" `twith` (aid, body, side)) () let !_A = assert (not (bproj body) `blame` "AI gets to manually move its projectiles" `twith` (aid, body, side)) () stratTarget <- targetStrategy aid tgtMPath <- if nullStrategy stratTarget then -- equiv to nullFreq -- 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 (tgt, pathEtc) _ -> Nothing -- | Pick an action the actor will perfrom this turn. pickAction :: MonadClient m => (ActorId, Actor) -> m RequestAnyAbility pickAction (aid, body) = do side <- getsClient sside let !_A = assert (bfid body == side `blame` "AI tries to move enemy actor" `twith` (aid, bfid body, side)) () let !_A = assert (not (bproj body) `blame` "AI gets to manually move its projectiles" `twith` (aid, bfid body, side)) () stratAction <- actionStrategy aid let bestAction = bestVariant stratAction !_A = assert (not (nullFreq bestAction) -- equiv to nullStrategy `blame` "no AI action for actor" `twith` (stratAction, aid, body)) () -- Run the AI: chose an action from those given by the AI strategy. rndToAction $ frequency bestAction LambdaHack-0.5.0.0/Game/LambdaHack/Client/ProtocolClient.hs0000644000000000000000000000077112555256425021361 0ustar0000000000000000{-# 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 () LambdaHack-0.5.0.0/Game/LambdaHack/Client/UI/0000755000000000000000000000000012555256425016375 5ustar0000000000000000LambdaHack-0.5.0.0/Game/LambdaHack/Client/UI/InventoryClient.hs0000644000000000000000000013211012555256425022063 0ustar0000000000000000{-# LANGUAGE DataKinds #-} -- | Inventory management and party cycling. -- TODO: document module Game.LambdaHack.Client.UI.InventoryClient ( Suitability(..) , getGroupItem, getAnyItems, getStoreItem , memberCycle, memberBack, pickLeader , cursorPointerFloor, cursorPointerEnemy , moveCursorHuman, tgtFloorHuman, tgtEnemyHuman, epsIncrHuman, tgtClearHuman , doLook, describeItemC ) where import Control.Applicative import Control.Exception.Assert.Sugar import Control.Monad import Data.Char (intToDigit) 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.Monoid import Data.Ord 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.HumanCmd 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 qualified Game.LambdaHack.Common.Ability as Ability import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState 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 Game.LambdaHack.Common.Request import Game.LambdaHack.Common.State import Game.LambdaHack.Common.Vector import qualified Game.LambdaHack.Content.ItemKind as IK data ItemDialogState = ISuitable | IAll | INoSuitable | INoAll deriving (Show, Eq) ppItemDialogMode :: ItemDialogMode -> (Text, Text) ppItemDialogMode (MStore cstore) = ppCStore cstore ppItemDialogMode MOwned = ("in", "our possession") ppItemDialogMode MStats = ("among", "strenghts") 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 storeFromMode :: ItemDialogMode -> CStore storeFromMode c = case c of MStore cstore -> cstore MOwned -> CGround -- needed to decide display mode in textAllAE MStats -> CGround -- needed to decide display mode in textAllAE accessModeBag :: ActorId -> State -> ItemDialogMode -> ItemBag accessModeBag leader s (MStore cstore) = getActorBag leader cstore s accessModeBag leader s MOwned = let fid = bfid $ getActorBody leader s in sharedAllOwnedFid False fid s accessModeBag _ _ MStats = 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 => m Suitability -- ^ which items to consider suitable -> Text -- ^ specific prompt for only suitable items -> Text -- ^ generic prompt -> Bool -- ^ whether to enable setting cursor with mouse -> [CStore] -- ^ initial legal modes -> [CStore] -- ^ legal modes after Calm taken into account -> m (SlideOrCmd ((ItemId, ItemFull), ItemDialogMode)) getGroupItem psuit prompt promptGeneric cursor cLegalRaw cLegalAfterCalm = do let dialogState = if cursor then INoSuitable else ISuitable soc <- getFull psuit (\_ _ cCur -> prompt <+> ppItemDialogModeFrom cCur) (\_ _ cCur -> promptGeneric <+> ppItemDialogModeFrom cCur) cursor cLegalRaw cLegalAfterCalm True False dialogState case soc of Left sli -> return $ Left sli Right ([(iid, itemFull)], c) -> return $ Right ((iid, itemFull), c) Right _ -> assert `failure` soc -- | Let the human player choose any item from a list of items -- and let him specify the number of items. -- Used, e.g., for picking up and inventory manipulation. getAnyItems :: MonadClientUI m => m Suitability -- ^ which items to consider suitable -> Text -- ^ specific prompt for only suitable items -> Text -- ^ generic prompt -> [CStore] -- ^ initial legal modes -> [CStore] -- ^ legal modes after Calm taken into account -> Bool -- ^ whether to ask, when the only item -- in the starting mode is suitable -> Bool -- ^ whether to ask for the number of items -> m (SlideOrCmd ([(ItemId, ItemFull)], ItemDialogMode)) getAnyItems psuit prompt promptGeneric cLegalRaw cLegalAfterCalm askWhenLone askNumber = do soc <- getFull psuit (\_ _ cCur -> prompt <+> ppItemDialogModeFrom cCur) (\_ _ cCur -> promptGeneric <+> ppItemDialogModeFrom cCur) False cLegalRaw cLegalAfterCalm askWhenLone True ISuitable 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) Right _ -> return 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 => (Actor -> [ItemFull] -> ItemDialogMode -> Text) -- ^ how to describe suitable items -> ItemDialogMode -- ^ initial mode -> m (SlideOrCmd ((ItemId, ItemFull), ItemDialogMode)) getStoreItem prompt cInitial = do let allCs = map MStore [CEqp, CInv, CSha] ++ [MOwned] ++ map MStore [CGround, COrgan] ++ [MStats] (pre, rest) = break (== cInitial) allCs post = dropWhile (== cInitial) rest remCs = post ++ pre soc <- getItem (return SuitsEverything) prompt prompt False cInitial remCs True False (cInitial:remCs) ISuitable case soc of Left sli -> return $ Left sli Right ([(iid, itemFull)], c) -> return $ Right ((iid, itemFull), c) Right _ -> assert `failure` soc -- | 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 => m Suitability -- ^ which items to consider suitable -> (Actor -> [ItemFull] -> ItemDialogMode -> Text) -- ^ specific prompt for only suitable items -> (Actor -> [ItemFull] -> ItemDialogMode -> Text) -- ^ generic prompt -> Bool -- ^ whether to enable setting cursor with mouse -> [CStore] -- ^ initial legal modes -> [CStore] -- ^ legal modes with Calm taken into account -> Bool -- ^ whether to ask, when the only item -- in the starting mode is suitable -> Bool -- ^ whether to permit multiple items as a result -> ItemDialogState -- ^ the dialog state to start in -> m (SlideOrCmd ([(ItemId, ItemFull)], ItemDialogMode)) getFull psuit prompt promptGeneric cursor cLegalRaw cLegalAfterCalm askWhenLone permitMulitple initalState = do side <- getsClient sside leader <- getLeaderUI let aidNotEmpty store aid = do bag <- getsState $ getCBag (CActor aid store) return $! not $ EM.null bag partyNotEmpty store = do as <- getsState $ fidActorNotProjAssocs side bs <- mapM (aidNotEmpty store . fst) as return $! or bs mpsuit <- psuit let psuitFun = case mpsuit of SuitsEverything -> const True SuitsNothing _ -> const False SuitsSomething f -> f -- Move the first store that is non-empty for suitable items for this actor -- to the front, if any. getCStoreBag <- getsState $ \s cstore -> getCBag (CActor leader cstore) s let hasThisActor = not . EM.null . getCStoreBag case filter hasThisActor cLegalAfterCalm of [] -> if isNothing (find hasThisActor cLegalRaw) then do let contLegalRaw = map MStore cLegalRaw tLegal = map (MU.Text . ppItemDialogModeIn) contLegalRaw ppLegal = makePhrase [MU.WWxW "nor" tLegal] failWith $ "no items" <+> ppLegal else failSer ItemNotCalm haveThis@(headThisActor : _) -> do itemToF <- itemToFullClient let suitsThisActor store = let bag = getCStoreBag store in any (\(iid, kit) -> psuitFun $ itemToF iid kit) $ EM.assocs bag cThisActor cDef = fromMaybe cDef $ find suitsThisActor haveThis -- Don't display stores totally empty for all actors. cLegal <- filterM partyNotEmpty cLegalRaw let breakStores cInit = let (pre, rest) = break (== cInit) cLegal post = dropWhile (== cInit) rest in (MStore cInit, map MStore $ post ++ pre) -- The last used store may go before even the first nonempty store. lastStore <- getsClient slastStore firstStore <- if lastStore `notElem` cLegalAfterCalm then return $! cThisActor headThisActor else do (itemSlots, organSlots) <- getsClient sslots let lSlots = if lastStore == COrgan then organSlots else itemSlots lastSlot <- getsClient slastSlot case EM.lookup lastSlot lSlots of Nothing -> return $! cThisActor headThisActor Just lastIid -> case EM.lookup lastIid $ getCStoreBag lastStore of Nothing -> return $! cThisActor headThisActor Just kit -> do let lastItemFull = itemToF lastIid kit lastSuits = psuitFun lastItemFull cLast = cThisActor lastStore return $! if lastSuits && cLast /= CGround then lastStore else cLast let (modeFirst, modeRest) = breakStores firstStore getItem psuit prompt promptGeneric cursor modeFirst modeRest askWhenLone permitMulitple (map MStore cLegal) initalState -- | Let the human player choose a single, preferably suitable, -- item from a list of items. getItem :: MonadClientUI m => m Suitability -- ^ which items to consider suitable -> (Actor -> [ItemFull] -> ItemDialogMode -> Text) -- ^ specific prompt for only suitable items -> (Actor -> [ItemFull] -> ItemDialogMode -> Text) -- ^ generic prompt -> Bool -- ^ whether to enable setting cursor with mouse -> ItemDialogMode -- ^ first mode, legal or not -> [ItemDialogMode] -- ^ the (rest of) legal modes -> Bool -- ^ whether to ask, when the only item -- in the starting mode is suitable -> Bool -- ^ whether to permit multiple items as a result -> [ItemDialogMode] -- ^ all legal modes -> ItemDialogState -- ^ the dialog state to start in -> m (SlideOrCmd ([(ItemId, ItemFull)], ItemDialogMode)) getItem psuit prompt promptGeneric cursor cCur cRest askWhenLone permitMulitple cLegal initalState = do leader <- getLeaderUI accessCBag <- getsState $ accessModeBag leader let storeAssocs = EM.assocs . accessCBag allAssocs = concatMap storeAssocs (cCur : cRest) case (cRest, allAssocs) of ([], [(iid, k)]) | not askWhenLone -> do itemToF <- itemToFullClient return $ Right ([(iid, itemToF iid k)], cCur) _ -> transition psuit prompt promptGeneric cursor permitMulitple cLegal 0 cCur cRest initalState data DefItemKey m = DefItemKey { defLabel :: Text -- ^ can be undefined if not @defCond@ , defCond :: !Bool , defAction :: K.KM -> m (SlideOrCmd ([(ItemId, ItemFull)], ItemDialogMode)) } data Suitability = SuitsEverything | SuitsNothing Msg | SuitsSomething (ItemFull -> Bool) transition :: forall m. MonadClientUI m => m Suitability -> (Actor -> [ItemFull] -> ItemDialogMode -> Text) -> (Actor -> [ItemFull] -> ItemDialogMode -> Text) -> Bool -> Bool -> [ItemDialogMode] -> Int -> ItemDialogMode -> [ItemDialogMode] -> ItemDialogState -> m (SlideOrCmd ([(ItemId, ItemFull)], ItemDialogMode)) transition psuit prompt promptGeneric cursor permitMulitple cLegal numPrefix cCur cRest itemDialogState = do let recCall = transition psuit prompt promptGeneric cursor permitMulitple cLegal (itemSlots, organSlots) <- getsClient sslots leader <- getLeaderUI body <- getsState $ getActorBody leader activeItems <- activeItemsClient leader fact <- getsState $ (EM.! bfid body) . sfactionD hs <- partyAfterLeader leader bagAll <- getsState $ \s -> accessModeBag leader s cCur lastSlot <- getsClient slastSlot itemToF <- itemToFullClient Binding{brevMap} <- askBinding mpsuit <- psuit -- when throwing, this sets eps and checks cursor validity (suitsEverything, psuitFun) <- case mpsuit of SuitsEverything -> return (True, const True) SuitsNothing err -> do slides <- promptToSlideshow $ err <+> moreMsg void $ getInitConfirms ColorFull [] $ slides <> toSlideshow Nothing [[]] return (False, const False) -- When throwing, this function takes missile range into accout. SuitsSomething f -> return (False, f) let getSingleResult :: ItemId -> (ItemId, ItemFull) getSingleResult iid = (iid, itemToF iid (bagAll EM.! iid)) getResult :: ItemId -> ([(ItemId, ItemFull)], ItemDialogMode) getResult iid = ([getSingleResult iid], cCur) getMultResult :: [ItemId] -> ([(ItemId, ItemFull)], ItemDialogMode) getMultResult iids = (map getSingleResult iids, cCur) filterP iid kit = psuitFun $ itemToF iid kit bagAllSuit = EM.filterWithKey filterP bagAll isOrgan = cCur == MStore COrgan lSlots = if isOrgan then organSlots else itemSlots bagItemSlotsAll = EM.filter (`EM.member` bagAll) lSlots -- Predicate for slot matching the current prefix, unless the prefix -- is 0, in which case we display all slots, even if they require -- the user to start with number keys to get to them. -- Could be generalized to 1 if prefix 1x exists, etc., but too rare. hasPrefixOpen x _ = slotPrefix x == numPrefix || numPrefix == 0 bagItemSlotsOpen = EM.filterWithKey hasPrefixOpen bagItemSlotsAll hasPrefix x _ = slotPrefix x == numPrefix bagItemSlots = EM.filterWithKey hasPrefix bagItemSlotsOpen bag = EM.fromList $ map (\iid -> (iid, bagAll EM.! iid)) (EM.elems bagItemSlotsOpen) suitableItemSlotsAll = EM.filter (`EM.member` bagAllSuit) lSlots suitableItemSlotsOpen = EM.filterWithKey hasPrefixOpen suitableItemSlotsAll suitableItemSlots = EM.filterWithKey hasPrefix suitableItemSlotsOpen bagSuit = EM.fromList $ map (\iid -> (iid, bagAllSuit EM.! iid)) (EM.elems suitableItemSlotsOpen) (autoDun, autoLvl) = autoDungeonLevel fact multipleSlots = if itemDialogState `elem` [IAll, INoAll] then bagItemSlotsAll else suitableItemSlotsAll keyDefs :: [(K.KM, DefItemKey m)] keyDefs = filter (defCond . snd) $ [ (K.toKM K.NoModifier $ K.Char '?', DefItemKey { defLabel = "?" , defCond = not (EM.null bag) , defAction = \_ -> recCall numPrefix cCur cRest $ case itemDialogState of INoSuitable -> if EM.null bagSuit then IAll else ISuitable ISuitable -> if suitsEverything then INoAll else IAll IAll -> if EM.null bag then INoSuitable else INoAll INoAll -> if suitsEverything then ISuitable else INoSuitable }) , (K.toKM K.NoModifier $ K.Char '/', DefItemKey { defLabel = "/" , defCond = not $ null cRest , defAction = \_ -> do let calmE = calmEnough body activeItems mcCur = filter (`elem` cLegal) [cCur] (cCurAfterCalm, cRestAfterCalm) = case cRest ++ mcCur of c1@(MStore CSha) : c2 : rest | not calmE -> (c2, c1 : rest) [MStore CSha] | not calmE -> assert `failure` cRest c1 : rest -> (c1, rest) [] -> assert `failure` cRest recCall numPrefix cCurAfterCalm cRestAfterCalm itemDialogState }) , (K.toKM K.NoModifier $ K.Char '*', DefItemKey { defLabel = "*" , defCond = permitMulitple && not (EM.null multipleSlots) , defAction = \_ -> let eslots = EM.elems multipleSlots in return $ Right $ getMultResult eslots }) , (K.toKM K.NoModifier K.Return, DefItemKey { defLabel = if lastSlot `EM.member` labelItemSlotsOpen then let l = makePhrase [slotLabel lastSlot] in "RET(" <> l <> ")" -- l is on the screen list else "RET" , defCond = not (EM.null labelItemSlotsOpen) , defAction = \_ -> case EM.lookup lastSlot labelItemSlotsOpen of Just iid -> return $ Right $ getResult iid Nothing -> case EM.minViewWithKey labelItemSlotsOpen of Nothing -> assert `failure` "labelItemSlotsOpen empty" `twith` labelItemSlotsOpen Just ((l, _), _) -> do modifyClient $ \cli -> cli { slastSlot = l , slastStore = storeFromMode cCur } recCall numPrefix cCur cRest itemDialogState }) , let km = M.findWithDefault (K.toKM K.NoModifier K.Tab) MemberCycle brevMap in (km, DefItemKey { defLabel = K.showKM km , defCond = not (cCur == MOwned || autoLvl || not (any (\(_, b) -> blid b == blid body) hs)) , defAction = \_ -> do err <- memberCycle False let !_A = assert (err == mempty `blame` err) () (cCurUpd, cRestUpd) <- legalWithUpdatedLeader cCur cRest recCall numPrefix cCurUpd cRestUpd itemDialogState }) , let km = M.findWithDefault (K.toKM K.NoModifier K.BackTab) MemberBack brevMap in (km, DefItemKey { defLabel = K.showKM km , defCond = not (cCur == MOwned || autoDun || null hs) , defAction = \_ -> do err <- memberBack False let !_A = assert (err == mempty `blame` err) () (cCurUpd, cRestUpd) <- legalWithUpdatedLeader cCur cRest recCall numPrefix cCurUpd cRestUpd itemDialogState }) , let km = M.findWithDefault (K.toKM K.NoModifier (K.KP '/')) TgtFloor brevMap in cursorCmdDef False km tgtFloorHuman , let hackyCmd = Macro "" ["KP_Divide"] -- no keypad, but arrows enough km = M.findWithDefault (K.toKM K.NoModifier K.RightButtonPress) hackyCmd brevMap in cursorCmdDef False km tgtEnemyHuman , let km = M.findWithDefault (K.toKM K.NoModifier (K.KP '*')) TgtEnemy brevMap in cursorCmdDef False km tgtEnemyHuman , let hackyCmd = Macro "" ["KP_Multiply"] -- no keypad, but arrows OK km = M.findWithDefault (K.toKM K.NoModifier K.RightButtonPress) hackyCmd brevMap in cursorCmdDef False km tgtEnemyHuman , let km = M.findWithDefault (K.toKM K.NoModifier K.BackSpace) TgtClear brevMap in cursorCmdDef False km tgtClearHuman ] ++ numberPrefixes ++ [ let plusMinus = K.Char $ if b then '+' else '-' km = M.findWithDefault (K.toKM K.NoModifier plusMinus) (EpsIncr b) brevMap in cursorCmdDef False km (epsIncrHuman b) | b <- [True, False] ] ++ arrows ++ [ let km = M.findWithDefault (K.toKM K.NoModifier K.MiddleButtonPress) CursorPointerEnemy brevMap in cursorCmdDef False km (cursorPointerEnemy False False) , let km = M.findWithDefault (K.toKM K.Shift K.MiddleButtonPress) CursorPointerFloor brevMap in cursorCmdDef False km (cursorPointerFloor False False) , let km = M.findWithDefault (K.toKM K.NoModifier K.RightButtonPress) TgtPointerEnemy brevMap in cursorCmdDef True km (cursorPointerEnemy True True) ] prefixCmdDef d = (K.toKM K.NoModifier $ K.Char (intToDigit d), DefItemKey { defLabel = "" , defCond = True , defAction = \_ -> recCall (10 * numPrefix + d) cCur cRest itemDialogState }) numberPrefixes = map prefixCmdDef [0..9] cursorCmdDef verbose km cmd = (km, DefItemKey { defLabel = "keypad, mouse" , defCond = cursor && EM.null bagFiltered , defAction = \_ -> do look <- cmd when verbose $ void $ getInitConfirms ColorFull [] $ look <> toSlideshow Nothing [[]] recCall numPrefix cCur cRest itemDialogState }) arrows = let kCmds = K.moveBinding False False (`moveCursorHuman` 1) (`moveCursorHuman` 10) in map (uncurry $ cursorCmdDef False) kCmds lettersDef :: DefItemKey m lettersDef = DefItemKey { defLabel = slotRange $ EM.keys labelItemSlots , defCond = True , defAction = \K.KM{key} -> case key of K.Char l -> case EM.lookup (SlotChar numPrefix l) bagItemSlots of Nothing -> assert `failure` "unexpected slot" `twith` (l, bagItemSlots) Just iid -> return $ Right $ getResult iid _ -> assert `failure` "unexpected key:" `twith` K.showKey key } (labelItemSlotsOpen, labelItemSlots, bagFiltered, promptChosen) = case itemDialogState of ISuitable -> (suitableItemSlotsOpen, suitableItemSlots, bagSuit, prompt body activeItems cCur <> ":") IAll -> (bagItemSlotsOpen, bagItemSlots, bag, promptGeneric body activeItems cCur <> ":") INoSuitable -> (suitableItemSlotsOpen, suitableItemSlots, EM.empty, prompt body activeItems cCur <> ":") INoAll -> (bagItemSlotsOpen, bagItemSlots, EM.empty, promptGeneric body activeItems cCur <> ":") io <- case cCur of MStats -> statsOverlay leader -- TODO: describe each stat when selected _ -> itemOverlay (storeFromMode cCur) (blid body) bagFiltered runDefItemKey keyDefs lettersDef io bagItemSlots promptChosen statsOverlay :: MonadClient m => ActorId -> m Overlay statsOverlay aid = do b <- getsState $ getActorBody aid activeItems <- activeItemsClient aid let block n = n + if braced b then 50 else 0 prSlot :: (IK.EqpSlot, Int -> Text) -> Text prSlot (eqpSlot, f) = let fullText t = " " <> makePhrase [ MU.Text $ T.justifyLeft 22 ' ' $ IK.slotName eqpSlot , MU.Text t ] <> " " valueText = f $ sumSlotNoFilter eqpSlot activeItems in fullText valueText -- Some values can be negative, for others 0 is equivalent but shorter. slotList = -- TODO: [IK.EqpSlotAddHurtMelee..IK.EqpSlotAddLight] [ (IK.EqpSlotAddHurtMelee, \t -> tshow t <> "%") -- TODO: not applicable right now, IK.EqpSlotAddHurtRanged , (IK.EqpSlotAddArmorMelee, \t -> "[" <> tshow (block t) <> "%]") , (IK.EqpSlotAddArmorRanged, \t -> "{" <> tshow (block t) <> "%}") , (IK.EqpSlotAddMaxHP, \t -> tshow $ max 0 t) , (IK.EqpSlotAddMaxCalm, \t -> tshow $ max 0 t) , (IK.EqpSlotAddSpeed, \t -> tshow (max 0 t) <> "m/10s") , (IK.EqpSlotAddSight, \t -> tshow (max 0 $ min (fromIntegral $ bcalm b `div` (5 * oneM)) t) <> "m") , (IK.EqpSlotAddSmell, \t -> tshow (max 0 t) <> "m") , (IK.EqpSlotAddLight, \t -> tshow (max 0 t) <> "m") ] skills = sumSkills activeItems -- TODO: are negative total skills meaningful? prAbility :: Ability.Ability -> Text prAbility ability = let fullText t = " " <> makePhrase [ MU.Text $ T.justifyLeft 22 ' ' $ "ability" <+> tshow ability , MU.Text t ] <> " " valueText = tshow $ EM.findWithDefault 0 ability skills in fullText valueText abilityList = [minBound..maxBound] return $! toOverlay $ map prSlot slotList ++ map prAbility abilityList legalWithUpdatedLeader :: MonadClientUI m => ItemDialogMode -> [ItemDialogMode] -> m (ItemDialogMode, [ItemDialogMode]) legalWithUpdatedLeader cCur cRest = do leader <- getLeaderUI let newLegal = cCur : cRest -- not updated in any way yet b <- getsState $ getActorBody leader activeItems <- activeItemsClient leader let calmE = calmEnough b activeItems legalAfterCalm = case newLegal of c1@(MStore CSha) : c2 : rest | not calmE -> (c2, c1 : rest) [MStore CSha] | not calmE -> (MStore CGround, newLegal) c1 : rest -> (c1, rest) [] -> assert `failure` (cCur, cRest) return legalAfterCalm runDefItemKey :: MonadClientUI m => [(K.KM, DefItemKey m)] -> DefItemKey m -> Overlay -> EM.EnumMap SlotChar ItemId -> Text -> m (SlideOrCmd ([(ItemId, ItemFull)], ItemDialogMode)) runDefItemKey keyDefs lettersDef io labelItemSlots prompt = do let itemKeys = let slotKeys = map (K.Char . slotChar) (EM.keys labelItemSlots) defKeys = map fst keyDefs in map (K.toKM K.NoModifier) slotKeys ++ defKeys choice = let letterRange = defLabel lettersDef keyLabelsRaw = letterRange : map (defLabel . snd) keyDefs keyLabels = filter (not . T.null) keyLabelsRaw in "[" <> T.intercalate ", " (nub keyLabels) akm <- displayChoiceUI (prompt <+> choice) io itemKeys case akm of Left slides -> failSlides slides Right km -> case lookup km{K.pointer=Nothing} keyDefs of Just keyDef -> defAction keyDef km Nothing -> defAction lettersDef km 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 = map (K.toKM 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 side <- getsClient sside fact <- getsState $ (EM.! side) . sfactionD leader <- getLeaderUI body <- getsState $ getActorBody leader hs <- partyAfterLeader leader let autoLvl = snd $ autoDungeonLevel fact case filter (\(_, b) -> blid b == blid body) hs of _ | autoLvl -> failMsg $ showReqFailure NoChangeLvlLeader [] -> failMsg "cannot pick any other member on this level" (np, b) : _ -> do success <- pickLeader verbose np let !_A = assert (success `blame` "same leader" `twith` (leader, np, b)) () return mempty -- | Switches current member to the previous in the whole dungeon, wrapping. memberBack :: MonadClientUI m => Bool -> m Slideshow memberBack verbose = do side <- getsClient sside fact <- getsState $ (EM.! side) . sfactionD leader <- getLeaderUI hs <- partyAfterLeader leader let (autoDun, autoLvl) = autoDungeonLevel fact case reverse hs of _ | autoDun -> failMsg $ showReqFailure NoChangeDunLeader _ | autoLvl -> failMsg $ showReqFailure NoChangeLvlLeader [] -> failMsg "no other member in the party" (np, b) : _ -> do success <- pickLeader verbose np let !_A = assert (success `blame` "same leader" `twith` (leader, np, b)) () return mempty partyAfterLeader :: MonadStateRead m => ActorId -> m [(ActorId, Actor)] partyAfterLeader leader = do faction <- getsState $ bfid . getActorBody leader allA <- getsState $ EM.assocs . sactorD let factionA = filter (\(_, body) -> not (bproj body) && bfid body == faction) allA hs = sortBy (comparing keySelected) factionA 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 let !_A = assert (not (bproj pbody) `blame` "projectile chosen as the leader" `twith` (aid, pbody)) () -- 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 cursorPointerFloor :: MonadClientUI m => Bool -> Bool -> m Slideshow cursorPointerFloor verbose addMoreMsg = do km <- getsClient slastKM lidV <- viewedLevel Level{lxsize, lysize} <- getLevel lidV case K.pointer km of Just(newPos@Point{..}) | px >= 0 && py >= 0 && px < lxsize && py < lysize -> do let scursor = TPoint lidV newPos modifyClient $ \cli -> cli {scursor, stgtMode = Just $ TgtMode lidV} if verbose then doLook addMoreMsg else do displayPush "" -- flash the targeting line and path displayDelay -- for a bit longer return mempty _ -> do stopPlayBack return mempty cursorPointerEnemy :: MonadClientUI m => Bool -> Bool -> m Slideshow cursorPointerEnemy verbose addMoreMsg = do km <- getsClient slastKM lidV <- viewedLevel Level{lxsize, lysize} <- getLevel lidV case K.pointer km of Just(newPos@Point{..}) | px >= 0 && py >= 0 && px < lxsize && py < lysize -> do bsAll <- getsState $ actorAssocs (const True) lidV let scursor = case find (\(_, m) -> bpos m == newPos) bsAll of Just (im, _) -> TEnemy im True Nothing -> TPoint lidV newPos modifyClient $ \cli -> cli {scursor, stgtMode = Just $ TgtMode lidV} if verbose then doLook addMoreMsg else do displayPush "" -- flash the targeting line and path displayDelay -- for a bit longer return mempty _ -> do stopPlayBack return mempty -- | 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 False -- | 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 False 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 actor 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) && bhp b > 0 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 False -- | 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 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 False -- | Perform look around in the current position of the cursor. -- Normally expects targeting mode and so that a leader is picked. doLook :: MonadClientUI m => Bool -> m Slideshow doLook addMoreMsg = 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 False 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) inhabitants subject = MU.WWandW subjects verb = "be here" desc = if not (null rest) -- many actors, only list names then "" else case itemDisco $ itemToF (btrunk body) (1, []) of Nothing -> "" -- no details, only show the name Just ItemDisco{itemKind} -> IK.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 {- targeting is kind of a menu (or at least mode), so this is menu inside a menu, which is messy, hence disabled until UI overhauled: -- Check if there's something lying around at current position. is <- getsState $ getCBag $ CFloor lidV p if EM.size is <= 2 then promptToSlideshow lookMsg else do msgAdd lookMsg -- TODO: do not add to history floorItemOverlay lidV p -} promptToSlideshow $ lookMsg <+> if addMoreMsg then moreMsg else "" -- | Create a list of item names. _floorItemOverlay :: MonadClientUI m => LevelId -> Point -> m (SlideOrCmd (RequestTimed 'Ability.AbMoveItem)) _floorItemOverlay _lid _p = describeItemC MOwned {-CFloor lid p-} describeItemC :: MonadClientUI m => ItemDialogMode -> m (SlideOrCmd (RequestTimed 'Ability.AbMoveItem)) describeItemC c = do let subject = partActor verbSha body activeItems = if calmEnough body activeItems then "notice" else "paw distractedly" prompt body activeItems c2 = let (tIn, t) = ppItemDialogMode c2 in case c2 of MStore CGround -> -- TODO: variant for actors without (unwounded) feet makePhrase [ MU.Capitalize $ MU.SubjectVerbSg (subject body) "notice" , MU.Text "at" , MU.WownW (MU.Text $ bpronoun body) $ MU.Text "feet" ] MStore CSha -> makePhrase [ MU.Capitalize $ MU.SubjectVerbSg (subject body) (verbSha body activeItems) , MU.Text tIn , MU.Text t ] MStore COrgan -> makePhrase [ MU.Capitalize $ MU.SubjectVerbSg (subject body) "feel" , MU.Text tIn , MU.WownW (MU.Text $ bpronoun body) $ MU.Text t ] MOwned -> makePhrase [ MU.Capitalize $ MU.SubjectVerbSg (subject body) "recall" , MU.Text tIn , MU.Text t ] MStats -> makePhrase [ MU.Capitalize $ MU.SubjectVerbSg (subject body) "estimate" , MU.WownW (MU.Text $ bpronoun body) $ MU.Text t ] _ -> makePhrase [ MU.Capitalize $ MU.SubjectVerbSg (subject body) "see" , MU.Text tIn , MU.WownW (MU.Text $ bpronoun body) $ MU.Text t ] ggi <- getStoreItem prompt c case ggi of Right ((iid, itemFull), c2) -> do leader <- getLeaderUI b <- getsState $ getActorBody leader activeItems <- activeItemsClient leader let calmE = calmEnough b activeItems localTime <- getsState $ getLocalTime (blid b) let io = itemDesc (storeFromMode c2) localTime itemFull case c2 of MStore COrgan -> do let symbol = jsymbol (itemBase itemFull) blurb | symbol == '+' = "drop temporary conditions" | otherwise = "amputate organs" -- TODO: also forbid on the server, except in special cases. Left <$> overlayToSlideshow ("Can't" <+> blurb <> ", but here's the description.") io MStore CSha | not calmE -> Left <$> overlayToSlideshow "Not enough calm to take items from the shared stash, but here's the description." io MStore fromCStore -> do let prompt2 = "Where to move the item?" eqpFree = eqpFreeN b fstores :: [(K.Key, (CStore, Text))] fstores = filter ((/= fromCStore) . fst . snd) $ [ (K.Char 'p', (CInv, "inventory 'p'ack")) ] ++ [ (K.Char 'e', (CEqp, "'e'quipment")) | eqpFree > 0 ] ++ [ (K.Char 's', (CSha, "shared 's'tash")) | calmE ] ++ [ (K.Char 'g', (CGround, "'g'round")) ] choice = "[" <> T.intercalate ", " (map (snd . snd) fstores) keys = map (K.toKM K.NoModifier . K.Char) "epsg" akm <- displayChoiceUI (prompt2 <+> choice) io keys case akm of Left slides -> failSlides slides Right km -> do case lookup (K.key km) fstores of Nothing -> return $ Left mempty -- canceled Just (toCStore, _) -> do let k = itemK itemFull kToPick | toCStore == CEqp = min eqpFree k | otherwise = k socK <- pickNumber True kToPick case socK of Left slides -> return $ Left slides Right kChosen -> return $ Right $ ReqMoveItems [(iid, kChosen, fromCStore, toCStore)] MOwned -> do -- We can't move items from MOwned, because different copies may come -- from different stores and we can't guess player's intentions. found <- getsState $ findIid leader (bfid b) iid let !_A = assert (not (null found) `blame` ggi) () let ppLoc (_, CSha) = MU.Text $ ppCStoreIn CSha <+> "of the party" ppLoc (b2, store) = MU.Text $ ppCStoreIn store <+> "of" <+> bname b2 foundTexts = map ppLoc found prompt2 = makeSentence ["The item is", MU.WWandW foundTexts] Left <$> overlayToSlideshow prompt2 io MStats -> assert `failure` ggi Left slides -> return $ Left slides LambdaHack-0.5.0.0/Game/LambdaHack/Client/UI/Frontend.hs0000644000000000000000000001171412555256425020514 0ustar0000000000000000-- | 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 Data.Maybe 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 -- | The instructions sent by clients to the raw frontend over a channel. data FrontReq = FrontNormalFrame {frontFrame :: !SingleFrame} -- ^ show a frame | 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] , frontFromTop :: !(Maybe Bool) } -- ^ show a whole slideshow without interleaving with other clients | FrontAutoYes !Bool -- ^ set the frontend option for auto-answering prompts | 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) } -- | Initialize the frontend and apply the given continuation to the results -- of the initialization. startupF :: DebugModeCli -- ^ debug settings -> (Maybe (MVar ()) -> (ChanFrontend -> IO ()) -> IO ()) -- ^ continuation -> 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{K.pointer=Nothing} `elem` keys then return km else promptGetKey fs keys frame getConfirmGeneric :: Bool -> RawFrontend -> [K.KM] -> SingleFrame -> IO K.KM getConfirmGeneric autoYes fs clearKeys frame = do let DebugModeCli{sdisableAutoYes} = fdebugCli fs if autoYes && not sdisableAutoYes then do fdisplay fs (Just frame) return K.spaceKM else do let extraKeys = [K.spaceKM, K.escKM, K.pgupKM, K.pgdnKM] promptGetKey fs (clearKeys ++ extraKeys) frame -- Read UI requests from the client and send them to the frontend, loopFrontend :: RawFrontend -> ChanFrontend -> IO () loopFrontend fs ChanFrontend{..} = loop False where writeKM :: K.KM -> IO () writeKM km = STM.atomically $ STM.writeTQueue responseF km loop :: Bool -> IO () loop autoYes = do efr <- STM.atomically $ STM.readTQueue requestF case efr of FrontNormalFrame{..} -> do fdisplay fs (Just frontFrame) loop autoYes FrontDelay -> do fdisplay fs Nothing loop autoYes FrontKey{..} -> do km <- promptGetKey fs frontKM frontFr writeKM km loop autoYes FrontSlides{frontSlides = []} -> do -- Hack. fsyncFrames fs writeKM K.spaceKM loop autoYes FrontSlides{..} -> do let displayFrs frs srf = case frs of [] -> assert `failure` "null slides" `twith` frs [x] | isNothing frontFromTop -> do fdisplay fs (Just x) writeKM K.spaceKM x : xs -> do K.KM{..} <- getConfirmGeneric autoYes fs frontClear x case key of K.Esc -> writeKM K.escKM K.PgUp -> case srf of [] -> displayFrs frs srf y : ys -> displayFrs (y : frs) ys K.Space -> case xs of [] -> writeKM K.escKM -- hack _ -> displayFrs xs (x : srf) _ -> case xs of -- K.PgDn and any other permitted key [] -> displayFrs frs srf _ -> displayFrs xs (x : srf) case (frontFromTop, reverse frontSlides) of (Just False, r : rs) -> displayFrs [r] rs _ -> displayFrs frontSlides [] loop autoYes FrontAutoYes b -> loop b FrontFinish -> return () -- Do not loop again. LambdaHack-0.5.0.0/Game/LambdaHack/Client/UI/HandleHumanClient.hs0000644000000000000000000000756312555256425022267 0ustar0000000000000000-- | 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 = 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 True True False False v Run v -> fmap anyToUI <$> moveRunHuman True True True True v Wait -> Right <$> fmap ReqUITimed waitHuman MoveItem cLegalRaw toCStore mverb _ auto -> fmap ReqUITimed <$> moveItemHuman cLegalRaw toCStore mverb auto DescribeItem cstore -> fmap ReqUITimed <$> describeItemHuman cstore Project ts -> fmap ReqUITimed <$> projectHuman ts Apply ts -> fmap ReqUITimed <$> applyHuman ts AlterDir ts -> fmap ReqUITimed <$> alterDirHuman ts TriggerTile ts -> fmap ReqUITimed <$> triggerTileHuman ts RunOnceAhead -> fmap anyToUI <$> runOnceAheadHuman MoveOnceToCursor -> fmap anyToUI <$> moveOnceToCursorHuman RunOnceToCursor -> fmap anyToUI <$> runOnceToCursorHuman ContinueToCursor -> fmap anyToUI <$> continueToCursorHuman GameRestart t -> gameRestartHuman t GameExit -> gameExitHuman GameSave -> fmap Right gameSaveHuman Tactic -> tacticHuman Automate -> automateHuman -- Local. GameDifficultyCycle -> addNoSlides gameDifficultyCycle PickLeader k -> Left <$> pickLeaderHuman k MemberCycle -> Left <$> memberCycleHuman MemberBack -> Left <$> memberBackHuman SelectActor -> addNoSlides selectActorHuman SelectNone -> addNoSlides selectNoneHuman Clear -> addNoSlides clearHuman StopIfTgtMode -> addNoSlides stopIfTgtModeHuman SelectWithPointer -> addNoSlides selectWithPointer 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 TgtAscend k -> Left <$> tgtAscendHuman k EpsIncr b -> Left <$> epsIncrHuman b TgtClear -> Left <$> tgtClearHuman CursorUnknown -> Left <$> cursorUnknownHuman CursorItem -> Left <$> cursorItemHuman CursorStair up -> Left <$> cursorStairHuman up Cancel -> Left <$> cancelHuman mainMenuHuman Accept -> Left <$> acceptHuman helpHuman CursorPointerFloor -> addNoSlides cursorPointerFloorHuman CursorPointerEnemy -> addNoSlides cursorPointerEnemyHuman TgtPointerFloor -> Left <$> tgtPointerFloorHuman TgtPointerEnemy -> Left <$> tgtPointerEnemyHuman addNoSlides :: Monad m => m () -> m (SlideOrCmd RequestUI) addNoSlides cmdCli = cmdCli >> return (Left mempty) LambdaHack-0.5.0.0/Game/LambdaHack/Client/UI/Animation.hs0000644000000000000000000002414612555256425020657 0ustar0000000000000000{-# 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, actorX , swapPlaces, moveProj, 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 = EM.findWithDefault acOld 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 map (modifyFrame basicFrame) anim blank :: Maybe AttrChar blank = Nothing cSym :: Color -> Char -> Maybe AttrChar cSym 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)] mzipTriples :: (Point, Point, Point) -> (Maybe AttrChar, Maybe AttrChar, Maybe AttrChar) -> [(Point, AttrChar)] mzipTriples (p1, p2, p3) (mattr1, mattr2, mattr3) = let mzip (pos, mattr) = fmap (\x -> (pos, x)) mattr in catMaybes [mzip (p1, mattr1), mzip (p2, mattr2), mzip (p3, mattr3)] 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 -- TODO: in all but moveProj duplicate first and/or last frame, if required, -- since they are no longer duplicated in renderAnim -- | 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 , cSym BrCyan '\'') , (blank , cSym BrYellow '\'') , (blank , cSym BrYellow '^') , (cSym c1 '\\',cSym BrCyan '^') , (cSym c1 '|', cSym BrCyan '^') , (cSym c1 '%', blank) , (cSym c1 '/', blank) , (cSym c1 '-', blank) , (cSym c1 '\\',blank) , (cSym c2 '|', blank) , (cSym c2 '%', blank) , (cSym c2 '%', blank) , (cSym 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 , cSym BrCyan '\'') , (blank , cSym BrYellow '\'') , (blank , cSym BrYellow '^') , (blank , cSym BrCyan '^') , (cSym BrBlue '{', cSym BrCyan '\'') , (cSym BrBlue '{', cSym BrYellow '\'') , (cSym BrBlue '{', cSym BrYellow '\'') , (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 (EM.fromList . mzipPairs poss) [ (blank , cSym BrCyan '\'') , (blank , cSym BrYellow '^') , (cSym BrBlue '{', cSym BrYellow '\'') , (cSym BrBlue '{', cSym BrCyan '\'') , (cSym BrBlue '{', blank) , (cSym BrBlue '}', blank) , (cSym BrBlue '}', blank) , (cSym Blue '}', blank) , (cSym Blue '}', blank) ] -- | Death animation for an organic body. deathBody :: Point -> Animation deathBody pos = Animation $ map (maybe EM.empty (EM.singleton pos)) [ cSym BrRed '\\' , cSym BrRed '\\' , cSym BrRed '|' , cSym BrRed '|' , cSym BrRed '%' , cSym BrRed '%' , cSym BrRed '-' , cSym BrRed '-' , cSym BrRed '\\' , cSym BrRed '\\' , cSym BrRed '|' , cSym BrRed '|' , cSym BrRed '%' , cSym BrRed '%' , cSym BrRed '%' , cSym Red '%' , cSym Red '%' , cSym Red '%' , cSym Red '%' , cSym Red ';' , cSym Red ';' , cSym Red ',' ] -- | Mark actor location animation. actorX :: Point -> Char -> Color.Color -> Animation actorX pos symbol color = Animation $ map (maybe EM.empty (EM.singleton pos)) [ cSym BrRed 'X' , cSym BrRed 'X' , cSym BrRed symbol , cSym color symbol , cSym color symbol , cSym color symbol , cSym color symbol ] -- | Swap-places animation, both hostile and friendly. swapPlaces :: (Point, Point) -> Animation swapPlaces poss = Animation $ map (EM.fromList . 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) ] moveProj :: (Point, Point, Point) -> Char -> Color.Color -> Animation moveProj poss symbol color = Animation $ map (EM.fromList . mzipTriples poss) [ (cSym BrBlack '.', cSym color symbol , cSym color '.') -- , (cSym BrBlack '.', cSym BrBlack symbol, cSym color symbol) , (cSym BrBlack '.', cSym BrBlack '.' , cSym color symbol) , (blank , cSym BrBlack '.' , cSym color symbol) ] 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 fs return $! Animation $ if out then as else reverse (EM.empty : as) LambdaHack-0.5.0.0/Game/LambdaHack/Client/UI/Config.hs0000644000000000000000000001126512555256425020143 0ustar0000000000000000{-# LANGUAGE DeriveGeneric, FlexibleContexts #-} -- | 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 GHC.Generics (Generic) 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 , configColorIsBold :: !Bool , configHistoryMax :: !Int , configMaxFps :: !Int , configNoAnim :: !Bool , configRunStopMsgs :: !Bool } deriving (Show, Generic) 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" configColorIsBold = getOption "colorIsBold" configHistoryMax = getOption "historyMax" configMaxFps = max 1 $ getOption "maxFps" configNoAnim = getOption "noAnim" configRunStopMsgs = getOption "runStopMsgs" in Config{..} -- | Read and parse UI config file. mkConfig :: Kind.COps -> IO Config mkConfig Kind.COps{corule} = do let stdRuleset = Kind.stdRuleset corule cfgUIName = rcfgUIName stdRuleset sUIDefault = rcfgUIDefault stdRuleset 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.COps -> DebugModeCli applyConfigToDebug sconfig sdebugCli Kind.COps{corule} = let stdRuleset = Kind.stdRuleset corule in (\dbg -> dbg {sfont = sfont dbg `mplus` Just (configFont sconfig)}) . (\dbg -> dbg {scolorIsBold = scolorIsBold dbg `mplus` Just (configColorIsBold 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 LambdaHack-0.5.0.0/Game/LambdaHack/Client/UI/MsgClient.hs0000644000000000000000000001340012555256425020614 0ustar0000000000000000-- | Client monad for interacting with a human through UI. module Game.LambdaHack.Client.UI.MsgClient ( msgAdd, msgReset, recordHistory , SlideOrCmd, failWith, failSlides, failSer, failMsg , lookAt, itemOverlay ) where import Control.Applicative 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 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.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 qualified Game.LambdaHack.Content.TileKind as TK -- | 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 time <- getsState stime StateClient{sreport, shistory} <- getClient unless (nullReport sreport) $ do msgReset "" let nhistory = addReport shistory time sreport modifyClient $ \cli -> cli {shistory = nhistory} type SlideOrCmd a = Either Slideshow a failWith :: MonadClientUI m => Msg -> m (SlideOrCmd a) failWith msg = do stopPlayBack let starMsg = "*" <> msg <> "*" assert (not $ T.null msg) $ Left <$> promptToSlideshow starMsg failSlides :: MonadClientUI m => Slideshow -> m (SlideOrCmd a) failSlides slides = do stopPlayBack return $ Left slides failSer :: MonadClientUI m => ReqFailure -> m (SlideOrCmd a) failSer = failWith . showReqFailure failMsg :: MonadClientUI m => Msg -> m Slideshow failMsg msg = do stopPlayBack let starMsg = "*" <> msg <> "*" assert (not $ T.null msg) $ promptToSlideshow starMsg -- | 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 cops@Kind.COps{cotile=cotile@Kind.Ops{okind}} <- getsState scops itemToF <- itemToFullClient b <- getsState $ getActorBody aid stgtMode <- getsClient stgtMode let lidV = maybe (blid b) tgtLevelId stgtMode lvl <- getLevel lidV localTime <- getsState $ getLocalTime lidV subject <- partAidLeader aid is <- getsState $ getCBag $ CFloor lidV pos let verb = MU.Text $ if pos == bpos b then "stand on" else if canSee then "notice" else "remember" let nWs (iid, kit@(k, _)) = partItemWs k CGround localTime (itemToF iid kit) isd = case detailed of _ | EM.size is == 0 -> "" _ | EM.size is <= 2 -> makeSentence [ MU.SubjectVerbSg subject verb , MU.WWandW $ map nWs $ EM.assocs is] -- TODO: detailed unused here; disabled together with overlay in doLook True -> "\n" _ -> makeSentence [MU.Cardinal (EM.size is), "items here"] tile = lvl `at` pos obscured | knownLsecret lvl && tile /= hideTile cops lvl pos = "partially obscured" | otherwise = "" tileText = obscured <+> TK.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 -> LevelId -> ItemBag -> m Overlay itemOverlay c lid bag = do localTime <- getsState $ getLocalTime lid itemToF <- itemToFullClient (itemSlots, organSlots) <- getsClient sslots let isOrgan = c == COrgan lSlots = if isOrgan then organSlots else itemSlots let !_A = assert (all (`elem` EM.elems lSlots) (EM.keys bag) `blame` (c, lid, bag, lSlots)) () let pr (l, iid) = case EM.lookup iid bag of Nothing -> Nothing Just kit@(k, _) -> let itemFull = itemToF iid kit -- 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 c localTime itemFull ] <> " " return $! toOverlay $ mapMaybe pr $ EM.assocs lSlots LambdaHack-0.5.0.0/Game/LambdaHack/Client/UI/RunClient.hs0000644000000000000000000002646612555256425020652 0ustar0000000000000000{-# 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 ) 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 qualified Game.LambdaHack.Content.TileKind as TK -- | Continue running in the given direction. continueRun :: MonadClient m => LevelId -> RunParams -> m (Either Msg RequestAnyAbility) 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 then do let paramNew = paramIni {runMembers = rs } continueRun arena paramNew else if not onLevelLeader then do let paramNew = paramIni {runLeader = r} continueRun arena paramNew else 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 s <- getState modifyClient $ updateLeader r s modifyClient $ \cli -> cli {srunning = Just paramNew} return $ Right $ RequestAnyAbility $ 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-cursor 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-cursor -- 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 :: MonadClient m => RunParams -> m (Either Msg Vector) continueRunDir params = case params of RunParams{ runMembers = [] } -> assert `failure` params RunParams{ runLeader , runMembers = aid : _ , runInitial } -> do sreport <- getsClient sreport -- TODO: check the message before it goes into history let boringMsgs = map BS.pack [ "You hear a distant" , "reveals that the" ] boring repLine = any (`BS.isInfixOf` repLine) boringMsgs -- TODO: use a regexp from the UI config instead -- or have symbolic messages and pattern-match msgShown = isJust $ findInReport (not . boring) sreport if msgShown then return $ Left "message shown" else do cops@Kind.COps{cotile} <- getsState scops rbody <- getsState $ getActorBody runLeader let rposHere = bpos rbody rposLast = fromMaybe (assert `failure` (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 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 0 | accessibleDir 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 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 = fromMaybe (assert `failure` (aid, body)) (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 = EM.member pos $ lfloor lvl posThere = posHere `shift` dir actorsThere <- getsState $ posToActors posThere lid let posLast = fromMaybe (assert `failure` (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 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 = TK.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 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 LambdaHack-0.5.0.0/Game/LambdaHack/Client/UI/MonadClientUI.hs0000644000000000000000000003577212555256425021402 0ustar0000000000000000{-# 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, displayActorStart, drawOverlay -- * Assorted primitives , stopPlayBack, askConfig, askBinding , syncFrames, setFrontAutoYes, tryTakeMVarSescMVar, scoreToSlideshow , getLeaderUI, getArenaUI, viewedLevel , targetDescLeader, targetDescCursor , leaderTgtToPos, leaderTgtAims, cursorToPos ) where import Control.Applicative 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 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 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.Common.Time import qualified Game.LambdaHack.Content.ItemKind as IK 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. -- This includes a frontend session and keybinding info. data SessionUI = SessionUI { schanF :: !ChanFrontend -- ^ connection with the frontend , sbinding :: !Binding -- ^ binding of keys to commands , sescMVar :: !(Maybe (MVar ())) , sconfig :: !Config } -- | The monad that gives the client access to UI operations. 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 -- Assume we display the arena when we prompt for a key and possibly -- insert a delay and reset cutoff. arena <- getArenaUI localTime <- getsState $ getLocalTime arena -- No delay, because this is before the UI actor acts. Ideally the frame -- would not be changed either. -- However, set sdisplayed so that there's no extra delay after the actor -- acts either, because waiting for the key introduces enough delay. -- Or this is running, etc., which we want fast. let ageDisp = EM.insert arena localTime modifyClient $ \cli -> cli {sdisplayed = ageDisp $ sdisplayed cli} 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 $ Just frontFr -- Sync frames so that ESC doesn't skip frames. syncFrames modifyClient $ \cli -> cli {slastPlay = kms} return km _ -> do stopPlayBack -- we can't continue playback; wipe out old srunning writeConnFrontend FrontKey{..} km <- readConnFrontend modifyClient $ \cli -> cli {slastKM = km} return km (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 => Maybe Bool -> Overlay -> m K.KM getKeyOverlayCommand onBlank overlay = do frame <- drawOverlay (isJust 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 frontFromTop = onBlank frontSlides <- drawOverlays (isJust onBlank) dm ovs case frontSlides of [] -> 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 => Maybe SingleFrame -> m () displayFrame mf = do let frame = case mf of Nothing -> FrontDelay Just fr -> FrontNormalFrame fr writeConnFrontend frame displayDelay :: MonadClientUI m => m () displayDelay = replicateM_ 4 $ writeConnFrontend FrontDelay -- | 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). -- Insert delays, so that the animations don't look rushed. displayActorStart :: MonadClientUI m => Actor -> Frames -> m () displayActorStart b frs = do timeCutOff <- getsClient $ EM.findWithDefault timeZero (blid b) . sdisplayed localTime <- getsState $ getLocalTime (blid b) let delta = localTime `timeDeltaToFrom` timeCutOff when (delta > Delta timeClip && not (bproj b)) displayDelay let ageDisp = EM.insert (blid b) localTime modifyClient $ \cli -> cli {sdisplayed = ageDisp $ sdisplayed cli} mapM_ displayFrame frs -- | 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 False dm sfTop = do lid <- viewedLevel mleader <- getsClient _sleader tgtPos <- leaderTgtToPos cursorPos <- cursorToPos let anyPos = fromMaybe (Point 0 0) cursorPos -- if cursor invalid, e.g., on a wrong level; @draw@ ignores it later on pathFromLeader leader = Just <$> getCacheBfsAndPath leader anyPos bfsmpath <- maybe (return Nothing) pathFromLeader mleader tgtDesc <- maybe (return ("------", Nothing)) targetDescLeader mleader cursorDesc <- targetDescCursor draw 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 = ([], [], 0) -- TODO: not ideal, but needed to cancel macros that contain apostrophes , swaitTimes = - abs (swaitTimes cli) } srunning <- getsClient 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 s <- getState when (memActor runLeader arena s && not (noRunWithMulti 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=[], frontFromTop=Nothing} km <- readConnFrontend let !_A = assert (km == K.spaceKM) () return () setFrontAutoYes :: MonadClientUI m => Bool -> m () setFrontAutoYes b = writeConnFrontend $ FrontAutoYes b 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 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. scoreDict <- getsState shigh gameModeId <- getsState sgameModeId gameMode <- getGameMode time <- getsState stime date <- liftIO getClockTime scurDiff <- getsClient scurDiff factionD <- getsState sfactionD let table = HighScore.getTable gameModeId scoreDict gameModeName = mname gameMode showScore (ntable, pos) = HighScore.highSlideshow ntable pos gameModeName diff | fhasUI $ gplayer fact = scurDiff | otherwise = difficultyInverse scurDiff theirVic (fi, fa) | isAtWar fact fi && not (isHorrorFact 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 (fname $ gplayer fact) ourVictims theirVictims (fhiCondPoly $ gplayer fact) 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 -> getEntryArena 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 IK.EqpSlotAddMaxHP aid let percentage = 100 * bhp b `div` xM (max 5 maxHP) stars | percentage < 20 = "[____]" | percentage < 40 = "[*___]" | percentage < 60 = "[**__]" | percentage < 80 = "[***_]" | 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" <+> tshow 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 bag <- getsState $ getCBag (CFloor lid p) case EM.assocs bag of [] -> return $! "exact spot" <+> tshow p [(iid, kit@(k, _))] -> do localTime <- getsState $ getLocalTime lid itemToF <- itemToFullClient let (_, name, stats) = partItem CGround localTime (itemToF iid kit) return $! makePhrase $ if k == 1 then [name, stats] -- "a sword" too wordy else [MU.CarWs k name, stats] _ -> return $! "many items at" <+> tshow 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" <+> tshow p return (maybe invalidMsg validMsg tgtPos, Nothing) Nothing -> return ("crosshair 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 LambdaHack-0.5.0.0/Game/LambdaHack/Client/UI/HandleHumanGlobalClient.hs0000644000000000000000000010542212555256425023401 0ustar0000000000000000{-# LANGUAGE DataKinds, GADTs #-} -- | Semantics of 'Command.Cmd' client commands that return server commands. -- A couple of them do not take time, the rest does. -- Here prompts and menus and displayed, but any feedback resulting -- from the commands (e.g., from inventory manipulation) is generated later on, -- for all clients that witness the results of the commands. -- TODO: document module Game.LambdaHack.Client.UI.HandleHumanGlobalClient ( -- * Commands that usually take time moveRunHuman, waitHuman, moveItemHuman, describeItemHuman , projectHuman, applyHuman, alterDirHuman, triggerTileHuman , runOnceAheadHuman, moveOnceToCursorHuman , runOnceToCursorHuman, continueToCursorHuman -- * Commands that never take time , gameRestartHuman, gameExitHuman, gameSaveHuman, tacticHuman, 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.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.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 qualified Game.LambdaHack.Content.ItemKind as IK import Game.LambdaHack.Content.ModeKind import Game.LambdaHack.Content.TileKind (TileKind) import qualified Game.LambdaHack.Content.TileKind as TK -- * Move and Run moveRunHuman :: MonadClientUI m => Bool -> Bool -> Bool -> Bool -> Vector -> m (SlideOrCmd RequestAnyAbility) moveRunHuman initialStep finalGoal run runAhead dir = do tgtMode <- getsClient stgtMode if isJust tgtMode then 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 -- 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 <- getsClient sselected let runMembers = if runAhead || noRunWithMulti fact then [leader] -- TODO: warn? else ES.toList (ES.delete leader sel) ++ [leader] runParams = RunParams { runLeader = leader , runMembers , runInitial = True , runStopMsg = Nothing , runWaiting = 0 } macroRun25 = ["CTRL-comma", "CTRL-V"] when (initialStep && run) $ do modifyClient $ \cli -> cli {srunning = Just runParams} when runAhead $ modifyClient $ \cli -> cli {slastPlay = map K.mkKM macroRun25 ++ slastPlay cli} -- 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 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 runStopOrCmd <- moveSearchAlterAid leader dir case runStopOrCmd of Left stopMsg -> failWith stopMsg Right runCmd -> -- Don't check @initialStep@ and @finalGoal@ -- and don't stop going to target: door opening is mundane enough. return $ Right runCmd [(target, _)] | run && initialStep -> -- No @stopPlayBack@: initial displace is benign enough. -- Displacing requires accessibility, but it's checked later on. fmap RequestAnyAbility <$> displaceAid target _ : _ : _ | run && initialStep -> do let !_A = assert (all (bproj . snd) tgts) () failSer DisplaceProjectiles (target, tb) : _ | initialStep && finalGoal -> do stopPlayBack -- don't ever auto-repeat melee -- 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 let autoLvl = snd $ autoDungeonLevel fact if autoLvl then failSer NoChangeLvlLeader else do -- Select adjacent actor by bumping into him. Takes no time. success <- pickLeader True target let !_A = assert (success `blame` "bump self" `twith` (leader, target, tb)) () return $ Left mempty else -- Attacking does not require full access, adjacency is enough. fmap RequestAnyAbility <$> meleeAid target _ : _ -> failWith "actor in the way" -- | 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 Nothing -> failWith "nothing to melee with" Just 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 actorMaxSk = sumSkills activeItems immobile = EM.findWithDefault 0 AbMove actorMaxSk <= 0 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 (bproj tb) && atWar && immobile then failSer DisplaceImmobile 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) [_] -> return $ Right $ ReqDisplace target _ -> failSer DisplaceProjectiles else failSer DisplaceAccess -- | Actor moves or searches or alters. No visible actor at the position. moveSearchAlterAid :: MonadClient m => ActorId -> Vector -> m (Either Msg RequestAnyAbility) moveSearchAlterAid source dir = do cops@Kind.COps{cotile} <- getsState scops sb <- getsState $ getActorBody source actorSk <- actorSkillsClient source lvl <- getLevel $ blid sb let skill = EM.findWithDefault 0 AbAlter actorSk spos = bpos sb -- source position tpos = spos `shift` dir -- target position t = lvl `at` tpos runStopOrCmd -- Movement requires full access. | accessible cops lvl spos tpos = -- A 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. | 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) = if skill < 1 then Left $ showReqFailure AlterUnskilled else if EM.member tpos $ lfloor lvl 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 when an actor detected, -- it costs a turn and does not harm the invisible actors, -- so it's not so tempting. -- Ignore a known boring, not accessible tile. | otherwise = Left "never mind" return $! runStopOrCmd -- * 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 :: forall m. MonadClientUI m => [CStore] -> CStore -> Maybe MU.Part -> Bool -> m (SlideOrCmd (RequestTimed 'AbMoveItem)) moveItemHuman cLegalRaw destCStore mverb auto = do let !_A = assert (destCStore `notElem` cLegalRaw) () let verb = fromMaybe (MU.Text $ verbCStore destCStore) mverb leader <- getLeaderUI b <- getsState $ getActorBody leader activeItems <- activeItemsClient leader -- 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 activeItems cLegal | calmE = cLegalRaw | destCStore == CSha = [] | otherwise = delete CSha cLegalRaw ret4 :: MonadClientUI m => CStore -> [(ItemId, ItemFull)] -> Int -> [(ItemId, Int, CStore, CStore)] -> m (Either Slideshow [(ItemId, Int, CStore, CStore)]) ret4 _ [] _ acc = return $ Right $ reverse acc ret4 fromCStore ((iid, itemFull) : rest) oldN acc = do let k = itemK itemFull retRec toCStore = let n = oldN + if toCStore == CEqp then k else 0 in ret4 fromCStore rest n ((iid, k, fromCStore, toCStore) : acc) if cLegalRaw == [CGround] -- normal pickup then case destCStore of CEqp | calmE && goesIntoSha itemFull -> retRec CSha CEqp | not $ goesIntoEqp itemFull -> retRec CInv CEqp | 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 in the same pickup. -- TODO: try to ask for a number of items, thus giving the player -- the option of picking up a part. let fullWarn = if eqpOverfull b (oldN + 1) then EqpOverfull else EqpStackFull msgAdd $ "Warning:" <+> showReqFailure fullWarn <> "." retRec $ if calmE then CSha else CInv _ -> retRec destCStore else case destCStore of CEqp | eqpOverfull b (oldN + k) -> do -- If the chosen number from the stack doesn't fit, -- we don't equip any part of it and we exit item manipulation. let fullWarn = if eqpOverfull b (oldN + 1) then EqpOverfull else EqpStackFull failSer fullWarn _ -> retRec destCStore prompt = makePhrase ["What to", verb] promptEqp = makePhrase ["What consumable to", verb] p :: CStore -> (Text, m Suitability) p cstore = if cstore `elem` [CEqp, CSha] && cLegalRaw /= [CGround] then (promptEqp, return $ SuitsSomething goesIntoEqp) else (prompt, return SuitsEverything) (promptGeneric, psuit) = p destCStore ggi <- if auto then getAnyItems psuit prompt promptGeneric cLegalRaw cLegal False False else getAnyItems psuit prompt promptGeneric cLegalRaw cLegal True True case ggi of Right (l, MStore fromCStore) -> do leader2 <- getLeaderUI b2 <- getsState $ getActorBody leader2 activeItems2 <- activeItemsClient leader2 let calmE2 = calmEnough b2 activeItems2 -- This is not ideal, because the failure message comes late, -- but it's simple and good enough. if not calmE2 && destCStore == CSha then failSer ItemNotCalm else do l4 <- ret4 fromCStore l 0 [] return $! case l4 of Left sli -> Left sli Right [] -> assert `failure` ggi Right lr -> Right $ ReqMoveItems lr Left slides -> return $ Left slides _ -> assert `failure` ggi -- * DescribeItem -- | Display items from a given container store and describe the chosen one. describeItemHuman :: MonadClientUI m => ItemDialogMode -> m (SlideOrCmd (RequestTimed 'AbMoveItem)) describeItemHuman = describeItemC -- * Project projectHuman :: forall m. MonadClientUI m => [Trigger] -> m (SlideOrCmd (RequestTimed 'AbProject)) projectHuman ts = do leader <- getLeaderUI lidV <- viewedLevel oldTgtMode <- getsClient stgtMode -- Show the targeting line, temporarily. modifyClient $ \cli -> cli {stgtMode = Just $ TgtMode lidV} -- Set cursor to the personal target, permanently. tgt <- getsClient $ getTarget leader modifyClient $ \cli -> cli {scursor = fromMaybe (scursor cli) tgt} -- Let the user pick the item to fling. let posFromCursor :: m (Either Msg Point) posFromCursor = do canAim <- aidTgtAims leader lidV Nothing case canAim of Right newEps -> do -- Modify @seps@, permanently. modifyClient $ \cli -> cli {seps = newEps} mpos <- aidTgtToPos leader lidV Nothing case mpos of Nothing -> assert `failure` (tgt, leader, lidV) Just pos -> do munit <- projectCheck pos case munit of Nothing -> return $ Right pos Just reqFail -> return $ Left $ showReqFailure reqFail Left cause -> return $ Left cause mitem <- projectItem ts posFromCursor outcome <- case mitem of Right (iid, fromCStore) -> do mpos <- posFromCursor case mpos of Right pos -> do eps <- getsClient seps return $ Right $ ReqProject pos eps iid fromCStore Left cause -> failWith cause Left sli -> return $ Left sli modifyClient $ \cli -> cli {stgtMode = oldTgtMode} return outcome projectCheck :: MonadClientUI m => Point -> m (Maybe ReqFailure) projectCheck 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 case bla lxsize lysize eps spos tpos of Nothing -> return $ Just ProjectAimOnself Just [] -> assert `failure` "project from the edge of level" `twith` (spos, tpos, sb) Just (pos : _) -> do lvl <- getLevel lid let t = lvl `at` pos if not $ Tile.isWalkable cotile t then return $ Just ProjectBlockTerrain else do lab <- getsState $ posToActors pos lid if all (bproj . snd) lab then return Nothing else return $ Just ProjectBlockActor projectItem :: forall m. MonadClientUI m => [Trigger] -> m (Either Msg Point) -> m (SlideOrCmd (ItemId, CStore)) projectItem ts posFromCursor = do leader <- getLeaderUI b <- getsState $ getActorBody leader activeItems <- activeItemsClient leader actorSk <- actorSkillsClient leader let skill = EM.findWithDefault 0 AbProject actorSk calmE = calmEnough b activeItems cLegalRaw = [CGround, CInv, CEqp, CSha] cLegal | calmE = cLegalRaw | otherwise = delete CSha cLegalRaw (verb1, object1) = case ts of [] -> ("aim", "item") tr : _ -> (verb tr, object tr) triggerSyms = triggerSymbols ts psuitReq :: m (Either Msg (ItemFull -> Either ReqFailure Bool)) psuitReq = do mpos <- posFromCursor case mpos of Left err -> return $ Left err Right pos -> return $ Right $ \itemFull@ItemFull{itemBase} -> do let legal = permittedProject triggerSyms False skill itemFull b activeItems case legal of Left{} -> legal Right False -> legal Right True -> Right $ totalRange itemBase >= chessDist (bpos b) pos psuit :: m Suitability psuit = do mpsuitReq <- psuitReq case mpsuitReq of -- If target invalid, no item is considered a (suitable) missile. Left err -> return $ SuitsNothing err Right psuitReqFun -> return $ SuitsSomething $ \itemFull -> case psuitReqFun itemFull of Left _ -> False Right suit -> suit prompt = makePhrase ["What", object1, "to", verb1] promptGeneric = "What to fling" ggi <- getGroupItem psuit prompt promptGeneric True cLegalRaw cLegal case ggi of Right ((iid, itemFull), MStore fromCStore) -> do mpsuitReq <- psuitReq case mpsuitReq of Left err -> failWith err Right psuitReqFun -> case psuitReqFun itemFull of Left reqFail -> failSer reqFail Right _ -> return $ Right (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 b <- getsState $ getActorBody leader actorSk <- actorSkillsClient leader let skill = EM.findWithDefault 0 AbApply actorSk activeItems <- activeItemsClient leader localTime <- getsState $ getLocalTime (blid b) let calmE = calmEnough b activeItems cLegalRaw = [CGround, CInv, CEqp, CSha] cLegal | calmE = cLegalRaw | otherwise = delete CSha cLegalRaw (verb1, object1) = case ts of [] -> ("apply", "item") tr : _ -> (verb tr, object tr) triggerSyms = triggerSymbols ts p itemFull = permittedApply triggerSyms localTime skill itemFull b activeItems prompt = makePhrase ["What", object1, "to", verb1] promptGeneric = "What to apply" ggi <- getGroupItem (return $ SuitsSomething $ either (const False) id . p) prompt promptGeneric False cLegalRaw cLegal case ggi of Right ((iid, itemFull), MStore fromCStore) -> case p itemFull of Left reqFail -> failSer reqFail Right _ -> return $ Right $ ReqApply iid fromCStore Left slides -> return $ Left slides _ -> assert `failure` ggi -- * AlterDir -- TODO: accept mouse, too -- | 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 = map (K.toKM K.NoModifier) (K.dirAllKey configVi configLaptop) prompt = makePhrase ["What to", verb1 <> "? [movement key"] me <- displayChoiceUI prompt emptyOverlay keys case me of Left slides -> failSlides slides Right e -> K.handleDir configVi configLaptop e (`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 cops@Kind.COps{cotile} <- getsState scops leader <- getLeaderUI b <- getsState $ getActorBody leader actorSk <- actorSkillsClient leader lvl <- getLevel $ blid b as <- getsState $ actorList (const True) (blid b) let skill = EM.findWithDefault 0 AbAlter actorSk tpos = bpos b `shift` dir t = lvl `at` tpos alterFeats = alterFeatures ts case filter (\feat -> Tile.hasFeature cotile feat t) alterFeats of _ | skill < 1 -> failSer AlterUnskilled [] -> failWith $ guessAlter cops alterFeats t feat : _ -> if EM.notMember tpos $ lfloor lvl then if unoccupied as tpos then return $ Right $ ReqAlter tpos $ Just feat else failSer AlterBlockActor else failSer AlterBlockItem alterFeatures :: [Trigger] -> [TK.Feature] alterFeatures [] = [] alterFeatures (AlterFeature{feature} : ts) = feature : alterFeatures ts alterFeatures (_ : ts) = alterFeatures ts -- | Guess and report why the bump command failed. guessAlter :: Kind.COps -> [TK.Feature] -> Kind.Id TileKind -> Msg guessAlter Kind.COps{cotile} (TK.OpenTo _ : _) t | Tile.isClosable cotile t = "already open" guessAlter _ (TK.OpenTo _ : _) _ = "cannot be opened" guessAlter Kind.COps{cotile} (TK.CloseTo _ : _) t | Tile.isOpenable cotile t = "already closed" guessAlter _ (TK.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 = TK.Cause (IK.Ascend k)} : _ -> Just k _ : rest -> getK rest [] -> Nothing mk = getK ts case mk of Nothing -> failWith "never mind" Just k -> 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 cops@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 cops triggerFeats t feat : _ -> do go <- verifyTrigger leader feat case go of Right () -> return $ Right $ ReqTrigger $ Just feat Left slides -> return $ Left slides triggerFeatures :: [Trigger] -> [TK.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 -> TK.Feature -> m (SlideOrCmd ()) verifyTrigger leader feat = case feat of TK.Cause IK.Escape{} -> do b <- getsState $ getActorBody leader side <- getsClient sside fact <- getsState $ (EM.! side) . sfactionD if not (fcanEscape $ gplayer 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.COps -> [TK.Feature] -> Kind.Id TileKind -> Msg guessTrigger Kind.COps{cotile} fs@(TK.Cause (IK.Ascend k) : _) t | Tile.hasFeature cotile (TK.Cause (IK.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@(TK.Cause (IK.Ascend k) : _) _ = if k > 0 then "cannot ascend" else if k < 0 then "cannot descend" else assert `failure` fs guessTrigger _ _ _ = "never mind" -- * RunOnceAhead runOnceAheadHuman :: MonadClientUI m => m (SlideOrCmd RequestAnyAbility) runOnceAheadHuman = do side <- getsClient sside fact <- getsState $ (EM.! side) . sfactionD leader <- getLeaderUI srunning <- getsClient srunning -- When running, stop if disturbed. If not running, stop at once. case srunning of Nothing -> do stopPlayBack return $ Left mempty Just RunParams{runMembers} | noRunWithMulti fact && runMembers /= [leader] -> do stopPlayBack Config{configRunStopMsgs} <- askConfig if configRunStopMsgs then failWith "run stop: automatic leader change" else return $ Left mempty Just runParams -> do arena <- getArenaUI runOutcome <- continueRun arena runParams case runOutcome of Left stopMsg -> do stopPlayBack Config{configRunStopMsgs} <- askConfig if configRunStopMsgs then failWith $ "run stop:" <+> stopMsg else return $ Left mempty Right runCmd -> return $ Right runCmd -- * MoveOnceToCursor moveOnceToCursorHuman :: MonadClientUI m => m (SlideOrCmd RequestAnyAbility) moveOnceToCursorHuman = goToCursor True False goToCursor :: MonadClientUI m => Bool -> Bool -> m (SlideOrCmd RequestAnyAbility) goToCursor initialStep run = do tgtMode <- getsClient stgtMode -- Movement is legal only outside targeting mode. if isJust tgtMode then failWith "cannot move in aiming mode" else do leader <- getLeaderUI b <- getsState $ getActorBody leader cursorPos <- cursorToPos case cursorPos of Nothing -> failWith "crosshair position invalid" Just c | c == bpos b -> if initialStep then return $ Right $ RequestAnyAbility ReqWait else do report <- getsClient sreport if nullReport report then return $ Left mempty -- Mark that the messages are accumulated, not just from last move. else failWith "crosshair now reached" Just c -> do running <- getsClient srunning case running of -- Don't use running params from previous run or goto-cursor. Just paramOld | not initialStep -> do arena <- getArenaUI runOutcome <- multiActorGoTo arena c paramOld case runOutcome of Left stopMsg -> failWith stopMsg Right (finalGoal, dir) -> moveRunHuman initialStep finalGoal run False dir _ -> do let !_A = assert (initialStep || not run) () (_, mpath) <- getCacheBfsAndPath leader c case mpath of Nothing -> failWith "no route to crosshair" Just [] -> assert `failure` (leader, b, c) Just (p1 : _) -> do let finalGoal = p1 == c dir = towards (bpos b) p1 moveRunHuman initialStep finalGoal run False dir multiActorGoTo :: MonadClient m => LevelId -> Point -> RunParams -> m (Either Msg (Bool, Vector)) multiActorGoTo arena c paramOld = case paramOld of RunParams{runMembers = []} -> return $ Left "selected actors no longer there" RunParams{runMembers = r : rs, runWaiting} -> do onLevel <- getsState $ memActor r arena if not onLevel then do let paramNew = paramOld {runMembers = rs} multiActorGoTo arena c paramNew else do s <- getState modifyClient $ updateLeader r s let runMembersNew = rs ++ [r] paramNew = paramOld { runMembers = runMembersNew , runWaiting = 0} b <- getsState $ getActorBody r (_, mpath) <- getCacheBfsAndPath r c case mpath of Nothing -> return $ Left "no route to crosshair" Just [] -> -- This actor already at goal; will be caught in goToCursor. return $ Left "" Just (p1 : _) -> do let finalGoal = p1 == c dir = towards (bpos b) p1 tpos = bpos b `shift` dir tgts <- getsState $ posToActors tpos arena case tgts of [] -> do modifyClient $ \cli -> cli {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} _ -> return $ Left "actor in the way" -- * RunOnceToCursor runOnceToCursorHuman :: MonadClientUI m => m (SlideOrCmd RequestAnyAbility) runOnceToCursorHuman = goToCursor True True -- * ContinueToCursor continueToCursorHuman :: MonadClientUI m => m (SlideOrCmd RequestAnyAbility) continueToCursorHuman = goToCursor False False{-irrelevant-} -- * GameRestart; does not take time gameRestartHuman :: MonadClientUI m => GroupName ModeKind -> m (SlideOrCmd RequestUI) gameRestartHuman t = do let restart = do leader <- getLeaderUI snxtDiff <- getsClient snxtDiff Config{configHeroNames} <- askConfig return $ Right $ ReqUIGameRestart leader t snxtDiff configHeroNames escAI <- getsClient sescAI if escAI == EscAIExited then restart else do let msg = "You just requested a new" <+> tshow 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 restart -- * 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 return $ Right $ ReqUIGameExit leader else failWith "save and exit canceled" -- * GameSave; does not take time gameSaveHuman :: MonadClientUI m => m RequestUI gameSaveHuman = do -- Announce before the saving started, since it can take some time -- and may slow down the machine, even if not block the client. -- TODO: do not save to history: msgAdd "Saving game backup." return ReqUIGameSave -- * Tactic; does not take time -- Note that the difference between seek-target and follow-the-leader tactic -- 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. -- TODO: set tactic for allied passive factions, too or all allied factions -- and perhaps even factions with a leader should follow our leader -- and his target, not their leader. tacticHuman :: MonadClientUI m => m (SlideOrCmd RequestUI) tacticHuman = do fid <- getsClient sside fromT <- getsState $ ftactic . gplayer . (EM.! fid) . sfactionD let toT = if fromT == maxBound then minBound else succ fromT go <- displayMore ColorFull $ "Current tactic is '" <> tshow fromT <> "'. Switching tactic to '" <> tshow toT <> "'. (This clears targets.)" if not go then failWith "tactic change canceled" else return $ Right $ ReqUITactic toT -- * 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} escAI <- getsClient sescAI if escAI == EscAIExited then return $ Right ReqUIAutomate else do go <- displayMore ColorBW "Ceding control to AI (ESC to regain)." if not go then failWith "automation canceled" else return $ Right ReqUIAutomate LambdaHack-0.5.0.0/Game/LambdaHack/Client/UI/DrawClient.hs0000644000000000000000000004465512555256425021003 0ustar0000000000000000-- | 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 Data.List import Data.Maybe import Data.Ord 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 qualified Game.LambdaHack.Common.Ability as Ability 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 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.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 qualified Game.LambdaHack.Content.ItemKind as IK import Game.LambdaHack.Content.ModeKind import qualified Game.LambdaHack.Content.TileKind as TK -- | 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 => ColorMode -> LevelId -> Maybe Point -> Maybe Point -> Maybe (PointArray.Array BfsDistance, Maybe [Point]) -> (Text, Maybe Text) -> (Text, Maybe Text) -> Overlay -> m SingleFrame draw 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 = EM.findWithDefault EM.empty pos0 $ lfloor lvl (itemSlots, _) = sslots cli bagItemSlots = EM.filter (`EM.member` floorBag) itemSlots floorIids = EM.elems bagItemSlots -- first slot will be shown 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 = TK.tcolor tk | otherwise = TK.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 && sml > ltime -> (timeDeltaToDigit smellTimeout smlt, rainbow pos0) | otherwise -> case floorIids of [] -> (TK.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 "x-hair>" else "X-hair:") <+> 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] sfBlank = False 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 IK.EqpSlotAddMaxHP activeItems amaxCalm = sumSlotNoFilter IK.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{..} | resCurrentTurn < 0 || resPreviousTurn < 0 = addColor Color.BrRed -- alarming news have priority | resCurrentTurn > 0 || resPreviousTurn > 0 = addColor Color.BrGreen | otherwise = 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 actorSk <- actorSkillsClient leader b <- getsState $ getActorBody leader localTime <- getsState $ getLocalTime (blid b) allAssocs <- fullAssocsClient leader [CEqp, COrgan] let activeItems = map snd allAssocs calm10 = calmEnough10 b $ map snd allAssocs forced = assert (not $ bproj b) False permitted = permittedPrecious calm10 forced preferredPrecious = either (const False) id . permitted strongest = strongestMelee False localTime allAssocs strongestPreferred = filter (preferredPrecious . snd . snd) strongest damage = case strongestPreferred of _ | EM.findWithDefault 0 Ability.AbMelee actorSk <= 0 -> "0" [] -> "0" (_average, (_, itemFull)) : _ -> let getD :: IK.Effect -> Maybe Dice.Dice -> Maybe Dice.Dice getD (IK.Hurt dice) acc = Just $ dice + fromMaybe 0 acc getD (IK.Burn dice) acc = Just $ dice + fromMaybe 0 acc getD _ acc = acc mdice = case itemDisco itemFull of Just ItemDisco{itemAE=Just ItemAspectEffect{jeffects}} -> foldr getD Nothing jeffects Just ItemDisco{itemKind} -> foldr getD Nothing (IK.ieffects itemKind) Nothing -> Nothing tdice = case mdice of Nothing -> "0" Just dice -> tshow dice bonus = sumSlotNoFilter IK.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 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 allOurs <- getsState $ filter ((== side) . bfid) . EM.elems . sactorD ours <- getsState $ filter (not . bproj . snd) . actorAssocs (== side) drawnLevelId let viewOurs (aid, Actor{bsymbol, bcolor, bhp}) = 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 Color.AttrChar sattr $ if bhp > 0 then bsymbol else '%' maxViewed = width - 2 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 = map viewOurs $ take maxViewed $ sortBy (comparing keySelected) ours addAttr t = map (Color.AttrChar Color.defAttr) (T.unpack t) -- Don't show anything if the only actor in the dungeon is the leader. -- He's clearly highlighted on the level map, anyway. party = if length allOurs == 1 && length ours == 1 || null ours then [] else [star] ++ 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) $ fname $ gplayer fact return $! if T.null ourName || T.length ourName >= width then [] else addAttr $ ourName <> " " LambdaHack-0.5.0.0/Game/LambdaHack/Client/UI/StartupFrontendClient.hs0000644000000000000000000000600612555256425023234 0ustar0000000000000000-- | 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 loops 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 ()) -- ^ UI main loop -> (DebugModeCli -> SessionUI -> State -> StateClient -> chanServerAI -> IO ()) -- ^ AI main loop -> KeyKind -- ^ key and command content -> Kind.COps -- ^ game content -> DebugModeCli -- ^ client debug parameters -> ((FactionId -> chanServerUI -> IO ()) -> (FactionId -> chanServerAI -> IO ()) -> IO ()) -- ^ frontend main loop -> IO () srtFrontend executorUI executorAI copsClient cops sdebugCli exeServer = do -- UI config reloaded at each client start. sconfig <- mkConfig cops let !sbinding = stdBinding copsClient sconfig -- evaluate to check for errors sdebugMode = applyConfigToDebug sconfig sdebugCli cops defaultHist <- defaultHistory $ configHistoryMax sconfig 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 LambdaHack-0.5.0.0/Game/LambdaHack/Client/UI/KeyBindings.hs0000644000000000000000000001625712555256425021152 0ustar0000000000000000-- | 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.toKM K.NoModifier (K.Char (Char.intToDigit k)) , ([CmdMeta], PickLeader k) ) cmdWithHelp = rhumanCommands copsClient ++ configCommands cmdAll = cmdWithHelp ++ [ (K.mkKM "KP_Begin", ([CmdMove], Wait)) , (K.mkKM "CTRL-KP_Begin", ([CmdMove], Macro "" ["KP_Begin"])) , (K.mkKM "KP_5", ([CmdMove], Macro "" ["KP_Begin"])) , (K.mkKM "CTRL-KP_5", ([CmdMove], Macro "" ["KP_Begin"])) ] ++ (if configVi then [ (K.mkKM "period", ([CmdMove], Macro "" ["KP_Begin"])) ] else if configLaptop then [ (K.mkKM "i", ([CmdMove], Macro "" ["KP_Begin"])) , (K.mkKM "I", ([CmdMove], Macro "" ["KP_Begin"])) ] else []) ++ 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 . second snd) cmdAll } -- | Produce a set of help screens from the key bindings. keyHelp :: Binding -> Slideshow keyHelp Binding{bcmdList} = let movBlurb = [ "Walk throughout a level with mouse or numeric keypad (left diagram)" , "or its compact laptop replacement (middle) or the Vi text editor keys" , "(right, also known as \"Rogue-like keys\"; can be enabled in config.ui.ini)." , "Run, until disturbed, with left mouse button or 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 aiming mode (KEYPAD_* or \\) the same keys (or mouse) move the crosshair." , "Press 'KEYPAD_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 the minimal command set." ] minimalBlurb = [ "The following minimal command set lets you accomplish anything in the game," , "though not necessarily with the fewest number of keystrokes." , "Most of the other commands are shorthands, defined as macros" , "(with the exception of the advanced commands for assigning non-default" , "tactics and targets to your autonomous henchmen, if you have any)." , "" ] casualEndBlurb = [ "" , "Press SPACE to see the detailed descriptions of all commands." ] categoryBlurb = [ "" , "Press SPACE to see the next page of command descriptions." ] lastBlurb = [ "" , "For more playing instructions see file PLAYING.md." , "Press PGUP to return to previous pages or ESC to see the map again." ] pickLeaderDescription = [ fmt 16 "0, 1 ... 6" "pick a particular actor as the new leader" ] casualDescription = "Minimal cheat sheet for casual play" fmt n k h = T.justifyRight 72 ' ' $ T.justifyLeft n ' ' k <> T.justifyLeft 48 ' ' h fmts s = " " <> T.justifyLeft 71 ' ' s movText = map fmts movBlurb minimalText = map fmts minimalBlurb casualEndText = map fmts casualEndBlurb categoryText = map fmts categoryBlurb lastText = map fmts lastBlurb coImage :: K.KM -> [K.KM] coImage k = k : sort [ from | (from, (_, cats, Macro _ [to])) <- bcmdList , K.mkKM to == k , any (`notElem` [CmdDebug, CmdInternal]) cats ] disp k = T.concat $ intersperse " or " $ map K.showKM $ coImage k keysN n cat = [ fmt n (disp k) h | (k, (h, cats, _)) <- bcmdList, cat `elem` cats, h /= "" ] -- TODO: measure the longest key sequence and set the caption automatically keyCaptionN n = fmt n "keys" "command" keys = keysN 16 keyCaption = keyCaptionN 16 in toSlideshow (Just True) [ [casualDescription <+> "(1/2). [press SPACE to see more]"] ++ [""] ++ movText ++ [moreMsg] , [casualDescription <+> "(2/2). [press SPACE to see all commands]"] ++ [""] ++ minimalText ++ [keyCaption] ++ keys CmdMinimal ++ casualEndText ++ [moreMsg] , ["All terrain exploration and alteration commands" <> ". [press SPACE to advance]"] ++ [""] ++ [keyCaptionN 10] ++ keysN 10 CmdMove ++ categoryText ++ [moreMsg] , [categoryDescription CmdItem <> ". [press SPACE to advance]"] ++ [""] ++ [keyCaptionN 10] ++ keysN 10 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 <> ". [press SPACE to advance]"] ++ [""] ++ [keyCaption] ++ keys CmdMeta ++ pickLeaderDescription ++ categoryText ++ [moreMsg] , [categoryDescription CmdMouse <> ". [press PGUP to see previous, ESC to cancel]"] ++ [""] ++ [keyCaptionN 21] ++ keysN 21 CmdMouse ++ lastText ++ [endMsg] ] LambdaHack-0.5.0.0/Game/LambdaHack/Client/UI/WidgetClient.hs0000644000000000000000000002140712555256425021317 0ustar0000000000000000-- | A set of widgets for UI clients. module Game.LambdaHack.Client.UI.WidgetClient ( displayMore, displayYesNo, displayChoiceUI, displayPush, describeMainKeys , promptToSlideshow, overlayToSlideshow, overlayToBlankSlideshow , animate, fadeOutOrIn ) where import Control.Applicative import qualified Data.EnumMap.Strict as EM import qualified Data.Map.Strict as M import Data.Maybe import Data.Monoid import qualified Data.Text as T 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.Config import Game.LambdaHack.Client.UI.Content.KeyKind import Game.LambdaHack.Client.UI.DrawClient import Game.LambdaHack.Client.UI.HumanCmd import Game.LambdaHack.Client.UI.KeyBindings 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 -- | A yes-no confirmation. getYesNo :: MonadClientUI m => SingleFrame -> m Bool getYesNo frame = do let keys = [ K.toKM K.NoModifier (K.Char 'y') , K.toKM K.NoModifier (K.Char 'n') , 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 Nothing [[]] -- | 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) <- slideshow <$> overlayToSlideshow (prompt <> ", ESC]") ov let extraKeys = [K.spaceKM, K.escKM, K.pgupKM, K.pgdnKM] legalKeys = keys ++ extraKeys loop frs srf = case frs of [] -> Left <$> promptToSlideshow "*never mind*" x : xs -> do frame <- drawOverlay False ColorFull x km@K.KM{..} <- promptGetKey legalKeys frame case key of _ | km `elem` keys -> return $ Right km -- km can be PgUp, etc. K.Esc -> Left <$> promptToSlideshow "*never mind*" K.PgUp -> case srf of [] -> loop frs srf y : ys -> loop (y : frs) ys K.Space -> case xs of [] -> Left <$> promptToSlideshow "*never mind*" _ -> loop xs (x : srf) _ -> case xs of -- K.PgDn and any other permitted key [] -> loop frs srf _ -> loop xs (x : srf) 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 => Msg -> m () displayPush prompt = do sls <- promptToSlideshow prompt let slide = head . snd $ slideshow sls frame <- drawOverlay False ColorFull slide displayFrame (Just frame) describeMainKeys :: MonadClientUI m => m Msg describeMainKeys = do side <- getsClient sside fact <- getsState $ (EM.! side) . sfactionD let underAI = isAIFact fact stgtMode <- getsClient stgtMode Binding{brevMap} <- askBinding Config{configVi, configLaptop} <- askConfig cursor <- getsClient scursor let kmLeftButtonPress = M.findWithDefault (K.toKM K.NoModifier K.LeftButtonPress) macroLeftButtonPress brevMap kmEscape = M.findWithDefault (K.toKM K.NoModifier K.Esc) Cancel brevMap kmCtrlx = M.findWithDefault (K.toKM K.Control (K.KP 'x')) GameExit brevMap kmRightButtonPress = M.findWithDefault (K.toKM K.NoModifier K.RightButtonPress) TgtPointerEnemy brevMap kmReturn = M.findWithDefault (K.toKM K.NoModifier K.Return) Accept brevMap moveKeys | configVi = "hjklyubn, " | configLaptop = "uk8o79jl, " | otherwise = "" tgtKind = case cursor of TEnemy _ True -> "at actor" TEnemy _ False -> "at enemy" TEnemyPos _ _ _ True -> "at actor" TEnemyPos _ _ _ False -> "at enemy" TPoint{} -> "at position" TVector{} -> "with a vector" keys | underAI = "" | isNothing stgtMode = "Explore with keypad or keys or mouse: [" <> moveKeys <> T.intercalate ", " (map K.showKM [kmLeftButtonPress, kmCtrlx, kmEscape]) <> "]" | otherwise = "Aim" <+> tgtKind <+> "with keypad or keys or mouse: [" <> moveKeys <> T.intercalate ", " (map K.showKM [kmRightButtonPress, kmReturn, kmEscape]) <> "]" report <- getsClient sreport return $! if nullReport report then keys else "" -- | 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 promptAI <- msgPromptAI lid <- getArenaUI Level{lxsize, lysize} <- getLevel lid -- TODO: screen length or viewLevel sreport <- getsClient sreport let msg = splitReport lxsize (prependMsg promptAI (addMsg sreport prompt)) return $! splitOverlay Nothing (lysize + 1) msg overlay msgPromptAI :: MonadClientUI m => m Msg msgPromptAI = do side <- getsClient sside fact <- getsState $ (EM.! side) . sfactionD let underAI = isAIFact fact return $! if underAI then "[press ESC for Main Menu]" else "" overlayToBlankSlideshow :: MonadClientUI m => Bool -> Msg -> Overlay -> m Slideshow overlayToBlankSlideshow startAtTop prompt overlay = do lid <- getArenaUI Level{lysize} <- getLevel lid -- TODO: screen length or viewLevel return $! splitOverlay (Just startAtTop) (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 -- if cursor invalid, e.g., on a wrong level; @draw@ ignores it later on pathFromLeader leader = Just <$> getCacheBfsAndPath leader anyPos bfsmpath <- maybe (return Nothing) pathFromLeader mleader tgtDesc <- maybe (return ("------", Nothing)) targetDescLeader mleader cursorDesc <- targetDescCursor promptAI <- msgPromptAI let over = renderReport (prependMsg promptAI sreport) topLineOnly = truncateToOverlay over basicFrame <- draw 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 mapM_ displayFrame animFrs LambdaHack-0.5.0.0/Game/LambdaHack/Client/UI/HumanCmd.hs0000644000000000000000000001622312555256425020431 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} -- | Abstract syntax human player commands. module Game.LambdaHack.Client.UI.HumanCmd ( CmdCategory(..), HumanCmd(..), Trigger(..) , noRemoteHumanCmd, categoryDescription, cmdDescription ) where import Control.DeepSeq import Control.Exception.Assert.Sugar import Data.Maybe import Data.Text (Text) import GHC.Generics (Generic) import qualified NLP.Miniutter.English as MU import Game.LambdaHack.Common.Actor (verbCStore) import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.Msg import Game.LambdaHack.Common.Vector import Game.LambdaHack.Content.ModeKind import qualified Game.LambdaHack.Content.TileKind as TK data CmdCategory = CmdMenu | CmdMove | CmdItem | CmdTgt | CmdAuto | CmdMeta | CmdMouse | CmdInternal | CmdDebug | CmdMinimal deriving (Show, Read, Eq, Generic) instance NFData CmdCategory categoryDescription :: CmdCategory -> Text categoryDescription CmdMenu = "Main Menu" categoryDescription CmdMove = "Terrain exploration and alteration" categoryDescription CmdItem = "Item use" categoryDescription CmdTgt = "Aiming and targeting" categoryDescription CmdAuto = "Automation" categoryDescription CmdMeta = "Assorted" categoryDescription CmdMouse = "Mouse" categoryDescription CmdInternal = "Internal" categoryDescription CmdDebug = "Debug" categoryDescription CmdMinimal = "The minimal command set" -- | Abstract syntax of player commands. data HumanCmd = -- Global. -- These usually take time. Move !Vector | Run !Vector | Wait | MoveItem ![CStore] !CStore !(Maybe MU.Part) !MU.Part !Bool | DescribeItem !ItemDialogMode | Project ![Trigger] | Apply ![Trigger] | AlterDir ![Trigger] | TriggerTile ![Trigger] | RunOnceAhead | MoveOnceToCursor | RunOnceToCursor | ContinueToCursor -- Below this line, commands do not take time. | GameRestart !(GroupName ModeKind) | GameExit | GameSave | Tactic | Automate -- Local. -- Below this line, commands do not notify the server. | GameDifficultyCycle | PickLeader !Int | MemberCycle | MemberBack | SelectActor | SelectNone | Clear | StopIfTgtMode | SelectWithPointer | Repeat !Int | Record | History | MarkVision | MarkSmell | MarkSuspect | Help | MainMenu | Macro !Text ![String] -- These are mostly related to targeting. | MoveCursor !Vector !Int | TgtFloor | TgtEnemy | TgtAscend !Int | EpsIncr !Bool | TgtClear | CursorUnknown | CursorItem | CursorStair !Bool | Cancel | Accept | CursorPointerFloor | CursorPointerEnemy | TgtPointerFloor | TgtPointerEnemy deriving (Show, Read, Eq, Ord, Generic) instance NFData HumanCmd data Trigger = ApplyItem {verb :: !MU.Part, object :: !MU.Part, symbol :: !Char} | AlterFeature {verb :: !MU.Part, object :: !MU.Part, feature :: !TK.Feature} | TriggerFeature {verb :: !MU.Part, object :: !MU.Part, feature :: !TK.Feature} deriving (Show, Read, Eq, Ord, Generic) instance NFData Trigger -- | 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 MoveOnceToCursor -> True RunOnceToCursor -> True ContinueToCursor -> 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 _ store2 mverb object _ -> let verb = fromMaybe (MU.Text $ verbCStore store2) mverb in makePhrase [verb, object] DescribeItem (MStore CGround) -> "manage items on the ground" DescribeItem (MStore COrgan) -> "describe organs of the leader" DescribeItem (MStore CEqp) -> "manage equipment of the leader" DescribeItem (MStore CInv) -> "manage inventory pack of the leader" DescribeItem (MStore CSha) -> "manage the shared party stash" DescribeItem MOwned -> "describe all owned items" DescribeItem MStats -> "show the stats summary of the leader" Project ts -> triggerDescription ts Apply ts -> triggerDescription ts AlterDir ts -> triggerDescription ts TriggerTile ts -> triggerDescription ts RunOnceAhead -> "run once ahead" MoveOnceToCursor -> "move one step towards the crosshair" RunOnceToCursor -> "run selected one step towards the crosshair" ContinueToCursor -> "continue towards the crosshair" GameRestart t -> -- TODO: use mname for the game mode instead of t makePhrase ["new", MU.Capitalize $ MU.Text $ tshow t, "game"] GameExit -> "save and exit" GameSave -> "save game" Tactic -> "cycle tactic of non-leader team members (WIP)" 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" SelectActor -> "select (or deselect) a party member" SelectNone -> "deselect (or select) all on the level" Clear -> "clear messages" StopIfTgtMode -> "stop playback if in aiming mode" SelectWithPointer -> "select actors if pointer over actor list" 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 -> "toggle visible zone display" MarkSmell -> "toggle smell clues display" MarkSuspect -> "toggle suspect terrain display" Help -> "display help" MainMenu -> "display the Main Menu" Macro t _ -> t MoveCursor v 1 -> "move crosshair" <+> compassText v MoveCursor v k -> "move crosshair up to" <+> tshow k <+> "steps" <+> compassText v TgtFloor -> "cycle aiming styles" TgtEnemy -> "aim at an enemy" TgtAscend k | k == 1 -> "aim at next shallower level" TgtAscend k | k >= 2 -> "aim at" <+> tshow k <+> "levels shallower" TgtAscend k | k == -1 -> "aim at next deeper level" TgtAscend k | k <= -2 -> "aim at" <+> tshow (-k) <+> "levels deeper" TgtAscend _ -> assert `failure` "void level change when aiming" `twith` cmd EpsIncr True -> "swerve the aiming line" EpsIncr False -> "unswerve the aiming line" TgtClear -> "reset target/crosshair" CursorUnknown -> "set crosshair to the closest unknown spot" CursorItem -> "set crosshair to the closest item" CursorStair up -> "set crosshair to the closest stairs" <+> if up then "up" else "down" Cancel -> "cancel action, open Main Menu" Accept -> "accept target/choice" CursorPointerFloor -> "set crosshair to floor under pointer" CursorPointerEnemy -> "set crosshair to enemy under pointer" TgtPointerFloor -> "enter aiming mode and describe a tile" TgtPointerEnemy -> "enter aiming mode and describe an enemy" triggerDescription :: [Trigger] -> Text triggerDescription [] = "trigger a thing" triggerDescription (t : _) = makePhrase [verb t, object t] LambdaHack-0.5.0.0/Game/LambdaHack/Client/UI/DisplayAtomicClient.hs0000644000000000000000000012141612555256425022637 0ustar0000000000000000-- | 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.EnumSet as ES 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 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 qualified Game.LambdaHack.Content.ItemKind as IK import Game.LambdaHack.Content.ModeKind import Game.LambdaHack.Content.RuleKind import qualified Game.LambdaHack.Content.TileKind as TK -- * 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 _ -> do side <- getsClient sside let verb = "appear" <+> if bfid body == side then "" else "suddenly" createActorUI aid body verbose (MU.Text verb) UpdDestroyActor aid body _ -> do destroyActorUI aid body "die" "be destroyed" verbose side <- getsClient sside when (bfid body == side && not (bproj body)) stopPlayBack UpdCreateItem iid _ kit c -> do case c of CActor aid store -> do l <- updateItemSlotSide store aid iid case store of COrgan -> do let verb = MU.Text $ "become" <+> case fst kit of 1 -> "" k -> tshow k <> "-fold" -- This describes all such items already among organs, -- which is useful, because it shows "charging". itemAidVerbMU aid verb iid (Left Nothing) COrgan _ -> do itemVerbMU iid kit (MU.Text $ "appear" <+> ppContainer c) c mleader <- getsClient _sleader when (Just aid == mleader) $ modifyClient $ \cli -> cli { slastSlot = l , slastStore = store } CEmbed{} -> return () CFloor{} -> do -- If you want an item to be assigned to @slastSlot@, create it -- in @CActor aid CGround@, not in @CFloor@. void $ updateItemSlot CGround Nothing iid itemVerbMU iid kit (MU.Text $ "appear" <+> ppContainer c) c CTrunk{} -> assert `failure` c stopPlayBack UpdDestroyItem iid _ kit c -> itemVerbMU iid kit "disappear" 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 _ kit c -> do (itemSlots, _) <- getsClient sslots case lookup iid $ map swap $ EM.assocs itemSlots of Nothing -> -- never seen or would have a slot case c of CActor aid store -> -- Enemy actor fetching an item from shared stash, most probably. void $ updateItemSlotSide store aid iid CEmbed{} -> return () CFloor lid p -> do void $ updateItemSlot CGround Nothing iid scursorOld <- getsClient scursor case scursorOld of TEnemy{} -> return () -- probably too important to overwrite TEnemyPos{} -> return () _ -> modifyClient $ \cli -> cli {scursor = TPoint lid p} itemVerbMU iid kit "be spotted" c stopPlayBack CTrunk{} -> return () _ -> return () -- seen already (has a slot assigned) UpdLoseItem{} -> return () -- Move actors and items. UpdMoveActor aid source target -> moveActor oldState aid source target UpdWaitActor aid _ -> when verbose $ aidVerbMU aid "wait" UpdDisplaceActor source target -> displaceActorUI source target UpdMoveItem iid k aid c1 c2 -> moveItemUI iid k aid c1 c2 -- Change actor attributes. UpdAgeActor{} -> return () UpdRefillHP _ 0 -> return () UpdRefillHP aid n -> do when verbose $ aidVerbMU aid $ MU.Text $ (if n > 0 then "heal" else "lose") <+> tshow (abs $ n `divUp` oneM) <> "HP" mleader <- getsClient _sleader when (Just aid == mleader) $ do b <- getsState $ getActorBody aid hpMax <- sumOrganEqpClient IK.EqpSlotAddMaxHP aid when (bhp b >= xM hpMax && hpMax > 0 && resCurrentTurn (bhpDelta b) > 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 aidVerbMU aid "hear something" msgDuplicateScrap stopPlayBack UpdFidImpressedActor aid _fidOld fidNew -> do b <- getsState $ getActorBody aid actorVerbMU aid b $ if fidNew == bfid b then "get calmed and refocused" -- TODO: only show for liquids; for others say 'flash', etc. -- "get refocused by the fragrant moisture" else if fidNew == bfidOriginal b then "remember forgone allegiance suddenly" else "experience anxiety that weakens resolve and erodes loyalty" -- TODO "inhale the sweet smell that weakens resolve and erodes loyalty" UpdTrajectory{} -> return () UpdColorActor{} -> return () -- Change faction attributes. UpdQuitFaction fid mbody _ toSt -> quitFactionUI fid mbody toSt UpdLeadFaction fid (Just (source, _)) (Just (target, _)) -> do side <- getsClient sside when (fid == side) $ do fact <- getsState $ (EM.! side) . sfactionD -- 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'. 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{} -> return () 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 <> "." UpdTacticFaction{} -> return () UpdAutoFaction fid b -> do side <- getsClient sside when (fid == side) $ setFrontAutoYes b UpdRecordKill{} -> return () -- 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 $ TK.tname $ okind fromTile verb2 = "be" let msg = makeSentence [ MU.SubjectVerbSg subject verb , "that the" , MU.SubjectVerbSg subject2 verb2 , "a hidden" , MU.Text $ TK.tname $ okind toTile ] msgAdd msg UpdLearnSecrets{} -> return () UpdSpotTile{} -> return () UpdLoseTile{} -> return () UpdAlterSmell{} -> return () UpdSpotSmell{} -> return () UpdLoseSmell{} -> return () -- Assorted. UpdTimeItem{} -> return () UpdAgeGame{} -> return () UpdDiscover c iid _ _ _ -> discover c oldStateClient iid UpdCover{} -> return () -- don't spam when doing undo UpdDiscoverKind c iid _ -> discover c oldStateClient iid UpdCoverKind{} -> return () -- don't spam when doing undo UpdDiscoverSeed c iid _ _ -> discover c oldStateClient iid UpdCoverSeed{} -> return () -- don't spam when doing undo UpdPerception{} -> return () UpdRestart fid _ _ _ _ _ -> do void tryTakeMVarSescMVar -- clear ESC-pressed from end of previous game mode <- getGameMode 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 fact <- getsState $ (EM.! fid) . sfactionD setFrontAutoYes $ isAIFact fact UpdRestartServer{} -> return () UpdResume fid _ -> do fact <- getsState $ (EM.! fid) . sfactionD setFrontAutoYes $ isAIFact fact UpdResumeServer{} -> return () UpdKillExit{} -> return () UpdWriteSave -> when verbose $ msgAdd "Saving backup." UpdMsgAll msg -> msgAdd msg UpdRecordHistory _ -> recordHistory updateItemSlotSide :: MonadClient m => CStore -> ActorId -> ItemId -> m SlotChar updateItemSlotSide store aid iid = do side <- getsClient sside b <- getsState $ getActorBody aid if bfid b == side then updateItemSlot store (Just aid) iid else updateItemSlot store Nothing iid 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 not (bproj body) && 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] aidVerbMU :: MonadClientUI m => ActorId -> MU.Part -> m () aidVerbMU aid verb = do b <- getsState $ getActorBody aid actorVerbMU aid b verb itemVerbMU :: MonadClientUI m => ItemId -> ItemQuant -> MU.Part -> Container -> m () itemVerbMU iid kit@(k, _) verb c = assert (k > 0) $ do lid <- getsState $ lidFromC c localTime <- getsState $ getLocalTime lid itemToF <- itemToFullClient let subject = partItemWs k (storeFromC c) localTime (itemToF iid kit) msg | k > 1 = makeSentence [MU.SubjectVerb MU.PlEtc MU.Yes subject verb] | otherwise = makeSentence [MU.SubjectVerbSg subject verb] msgAdd msg -- TODO: split into 3 parts wrt ek and reuse somehow, e.g., the secret part -- We assume the item is inside the specified container. -- So, this function can't be used for, e.g., @UpdDestroyItem@. itemAidVerbMU :: MonadClientUI m => ActorId -> MU.Part -> ItemId -> Either (Maybe Int) Int -> CStore -> m () itemAidVerbMU aid verb iid ek cstore = do bag <- getsState $ getActorBag aid cstore -- The item may no longer be in @c@, but it was case iid `EM.lookup` bag of Nothing -> assert `failure` (aid, verb, iid, cstore) Just kit@(k, _) -> do itemToF <- itemToFullClient body <- getsState $ getActorBody aid let lid = blid body localTime <- getsState $ getLocalTime lid subject <- partAidLeader aid let itemFull = itemToF iid kit object = case ek of Left (Just n) -> assert (n <= k `blame` (aid, verb, iid, cstore)) $ partItemWs n cstore localTime itemFull Left Nothing -> let (_, name, stats) = partItem cstore localTime itemFull in MU.Phrase [name, stats] Right n -> assert (n <= k `blame` (aid, verb, iid, cstore)) $ let itemSecret = itemNoDisco (itemBase itemFull, n) (_, secretName, secretAE) = partItem cstore localTime itemSecret name = MU.Phrase [secretName, secretAE] nameList = if n == 1 then ["the", name] else ["the", MU.Text $ tshow n, MU.Ws name] in MU.Phrase nameList msg = makeSentence [MU.SubjectVerbSg subject verb, object] 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 mapM_ (\(iid, store) -> void $ updateItemSlotSide store aid iid) (getCarriedIidCStore body) side <- getsClient sside when (bfid body /= side) $ do fact <- getsState $ (EM.! bfid body) . sfactionD when (not (bproj body) && isAtWar fact side) $ -- 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 -- 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 <- getsClient slastLost when (ES.notMember aid lastLost && (not (bproj body) || verbose)) $ do actorVerbMU aid body verb animFrs <- animate (blid body) $ actorX (bpos body) (bsymbol body) (bcolor body) displayActorStart body animFrs lookAtMove aid destroyActorUI :: MonadClientUI m => ActorId -> Actor -> MU.Part -> MU.Part -> Bool -> m () destroyActorUI aid body verb verboseVerb verbose = do Kind.COps{corule} <- getsState scops side <- getsClient sside when (bfid body == side) $ do let upd = ES.delete aid modifyClient $ \cli -> cli {sselected = upd $ sselected cli} if bfid body == side && bhp body <= 0 && not (bproj body) then do when verbose $ actorVerbMU aid body verb let firstDeathEnds = rfirstDeathEnds $ Kind.stdRuleset corule fid = bfid body fact <- getsState $ (EM.! fid) . sfactionD actorsAlive <- anyActorsAlive fid (Just aid) -- TODO: deduplicate wrt Server -- TODO; actually show the --more- prompt, but not between fadeout frames unless (fneverEmpty (gplayer fact) && (not actorsAlive || firstDeathEnds)) $ void $ displayMore ColorBW "" else when verbose $ actorVerbMU aid body verboseVerb -- If pushed, animate spotting again, to draw attention to pushing. when (isNothing $ btrajectory body) $ modifyClient $ \cli -> cli {slastLost = ES.insert aid $ slastLost cli} -- TODO: deduplicate wrt Server anyActorsAlive :: MonadClient m => FactionId -> Maybe ActorId -> m Bool anyActorsAlive fid maid = do fact <- getsState $ (EM.! fid) . sfactionD if fleaderMode (gplayer fact) /= LeaderNull then return $! isJust $ gleader fact else do as <- getsState $ fidActorNotProjAssocs fid return $! not $ null $ maybe as (\aid -> filter ((/= aid) . fst) as) maid moveActor :: MonadClientUI m => State -> ActorId -> Point -> Point -> m () moveActor oldState aid source target = do lookAtMove aid body <- getsState $ getActorBody aid when (bproj body) $ do let oldpos = case EM.lookup aid $ sactorD oldState of Nothing -> assert `failure` (sactorD oldState, aid) -- If no old position, default to current, which is then overwritten -- in the animation. Just b -> fromMaybe source $ boldpos b let ps = (oldpos, source, target) animFrs <- animate (blid body) $ moveProj ps (bsymbol body) (bcolor body) displayActorStart body animFrs 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 moveItemUI :: MonadClientUI m => ItemId -> Int -> ActorId -> CStore -> CStore -> m () moveItemUI iid k aid cstore1 cstore2 = do let verb = verbCStore cstore2 b <- getsState $ getActorBody aid fact <- getsState $ (EM.! bfid b) . sfactionD let underAI = isAIFact fact mleader <- getsClient _sleader bag <- getsState $ getActorBag aid cstore2 let kit@(n, _) = bag EM.! iid itemToF <- itemToFullClient (itemSlots, _) <- getsClient sslots case lookup iid $ map swap $ EM.assocs itemSlots of Just l -> do when (Just aid == mleader) $ modifyClient $ \cli -> cli { slastSlot = l , slastStore = cstore2 } if cstore1 == CGround && Just aid == mleader && not underAI then do itemAidVerbMU aid (MU.Text verb) iid (Right k) cstore2 localTime <- getsState $ getLocalTime (blid b) msgAdd $ makePhrase [ "\n" , slotLabel l , "-" , partItemWs n cstore2 localTime (itemToF iid kit) , "\n" ] else when (not (bproj b) && bhp b > 0) $ -- don't announce death drops itemAidVerbMU aid (MU.Text verb) iid (Left $ Just k) cstore2 Nothing -> assert `failure` (iid, itemToF iid kit) quitFactionUI :: MonadClientUI m => FactionId -> Maybe Actor -> Maybe Status -> m () quitFactionUI fid mbody toSt = do Kind.COps{coitem=Kind.Ops{okind, ouniqGroup}} <- getsState scops fact <- getsState $ (EM.! fid) . sfactionD let fidName = MU.Text $ gname fact horror = isHorrorFact 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, stNewGame=Just gn} -> ( Just $ MU.Text $ "order mission restart in" <+> tshow gn <+> "mode" , Just $ if fid == side then "This time for real." else "Somebody couldn't stand the heat." ) Just Status{stOutcome=Restart, stNewGame=Nothing} -> assert `failure` (fid, mbody, toSt) 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 startingSlide <- promptToSlideshow moreMsg recordHistory -- we are going to exit or restart, so record let bodyToItemSlides b = do (bag, tot) <- getsState $ calculateTotal b let currencyName = MU.Text $ IK.iname $ okind $ ouniqGroup "currency" itemMsg = makeSentence [ "Your loot is worth" , MU.CarWs tot currencyName ] <+> moreMsg if EM.null bag then return (mempty, 0) else do io <- itemOverlay CGround (blid b) bag sli <- overlayToSlideshow itemMsg io return (sli, tot) (itemSlides, total) <- case mbody of Just b | fid == side -> bodyToItemSlides b _ -> case gleader fact of Nothing -> return (mempty, 0) Just (aid, _) -> do b <- getsState $ getActorBody aid bodyToItemSlides b -- Show score for any UI client (except after ESC), -- even though it is saved only for human UI clients. scoreSlides <- scoreToSlideshow total status partingSlide <- promptToSlideshow $ pp <+> moreMsg shutdownSlide <- promptToSlideshow pp escAI <- getsClient sescAI unless (escAI == EscAIExited) $ -- 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 => Container -> StateClient -> ItemId -> m () discover c oldcli iid = do let cstore = storeFromC c lid <- getsState $ lidFromC c cops <- getsState scops localTime <- getsState $ getLocalTime lid itemToF <- itemToFullClient bag <- getsState $ getCBag c let kit = EM.findWithDefault (1, []) iid bag itemFull = itemToF iid kit knownName = partItemMediumAW cstore localTime 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 cstore localTime itemSecret msg = makeSentence [ "the", MU.SubjectVerbSg (MU.Phrase [secretName, secretAEText]) "turn out to be" , knownName ] oldItemFull = itemToFull cops (sdiscoKind oldcli) (sdiscoEffect oldcli) iid (itemBase itemFull) (1, []) -- Compare descriptions of all aspects and effects to determine -- if the discovery was meaningful to the player. when (textAllAE 7 False cstore itemFull /= textAllAE 7 False cstore 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 cstore b -> strike source target iid cstore b SfxRecoil source target _ _ _ -> do spart <- partAidLeader source tpart <- partAidLeader target msgAdd $ makeSentence [MU.SubjectVerbSg spart "shrink away from", tpart] SfxProject aid iid cstore -> do setLastSlot aid iid cstore itemAidVerbMU aid "aim" iid (Left $ Just 1) cstore SfxCatch aid iid cstore -> itemAidVerbMU aid "catch" iid (Left $ Just 1) cstore SfxApply aid iid cstore -> do setLastSlot aid iid cstore itemAidVerbMU aid "apply" iid (Left $ Just 1) cstore SfxCheck aid iid cstore -> itemAidVerbMU aid "deapply" iid (Left $ Just 1) cstore SfxTrigger aid _p _feat -> when verbose $ aidVerbMU aid "trigger" -- TODO: opens door, etc. SfxShun aid _p _ -> when verbose $ aidVerbMU 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 then do -- We assume the effect is the cause of incapacitation, but in case -- of projectile, to reduce spam, we verify with @canKill@. 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" -- Aspect bonuses ignored, so hurtExtra will add variety sometimes. deadPreviousTurn dp = bhp b <= dp harm2 dp = if deadPreviousTurn dp then (True, Just hurtExtra) else (False, Just firstFall) (deadBefore, mverbDie) = case effect of IK.Hurt p -> harm2 (- (xM $ Dice.maxDice p)) IK.RefillHP p | p < 0 -> harm2 (xM p) IK.OverfillHP p | p < 0 -> harm2 (xM p) IK.Burn p -> harm2 (- (xM $ Dice.maxDice p)) _ -> (False, Nothing) case mverbDie of Nothing -> return () -- only brutal effects work on dead/dying actor Just verbDie -> do subject <- partActorLeader aid b let 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 IK.NoEffect{} -> return () IK.Hurt{} -> return () -- avoid spam; SfxStrike just sent IK.Burn{} -> do if fid == side then actorVerbMU aid b "feel burned" else actorVerbMU aid b "look burned" let ps = (bpos b, bpos b) animFrs <- animate (blid b) $ twirlSplash ps Color.BrRed Color.Red displayActorStart b animFrs IK.Explode{} -> return () -- lots of visual feedback IK.RefillHP p | p == 1 -> return () -- no spam from regeneration IK.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 IK.RefillHP p | p == -1 -> return () -- no spam from poison IK.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 IK.OverfillHP 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 IK.OverfillHP _ -> 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 IK.RefillCalm p | p == 1 -> return () -- no spam from regen items IK.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 IK.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 IK.OverfillCalm 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 IK.OverfillCalm _ -> 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 IK.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 -- sometimes only a coincidence, but nm aidVerbMU aid $ MU.Text "yield, under extreme pressure" else if fid == side then aidVerbMU aid $ MU.Text "black out, dominated by foes" else aidVerbMU 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"] stopPlayBack IK.Impress -> return () IK.CallFriend{} -> do let verb = if bproj b then "attract" else "call forth" actorVerbMU aid b $ MU.Text $ verb <+> "friends" IK.Summon{} -> do -- TODO: if a singleton, use the freq? let verb = if bproj b then "lure" else "summon" actorVerbMU aid b $ MU.Text $ verb <+> "nearby beasts" IK.Ascend k | k > 0 -> actorVerbMU aid b "find a way upstairs" IK.Ascend k | k < 0 -> actorVerbMU aid b "find a way downstairs" IK.Ascend{} -> assert `failure` sfx IK.Escape{} -> return () IK.Paralyze{} -> actorVerbMU aid b "be paralyzed" IK.InsertMove{} -> actorVerbMU aid b "act with extreme speed" IK.Teleport t | t > 9 -> actorVerbMU aid b "teleport" IK.Teleport{} -> actorVerbMU aid b "blink" IK.CreateItem{} -> return () IK.DropItem COrgan _ True -> return () IK.DropItem _ _ False -> actorVerbMU aid b "be stripped" -- TODO IK.DropItem _ _ True -> actorVerbMU aid b "be violently stripped" IK.PolyItem -> do localTime <- getsState $ getLocalTime $ blid b allAssocs <- fullAssocsClient aid [CGround] case allAssocs of [] -> return () -- invisible items? (_, ItemFull{..}) : _ -> do subject <- partActorLeader aid b let itemSecret = itemNoDisco (itemBase, itemK) -- TODO: plural form of secretName? only when K > 1? -- At this point we don't easily know how many consumed. (_, secretName, secretAEText) = partItem CGround localTime itemSecret verb = "repurpose" store = MU.Text $ ppCStoreIn CGround msgAdd $ makeSentence [ MU.SubjectVerbSg subject verb , "the", secretName, secretAEText, store ] IK.Identify -> do allAssocs <- fullAssocsClient aid [CGround] case allAssocs of [] -> return () -- invisible items? (_, ItemFull{..}) : _ -> do subject <- partActorLeader aid b let verb = "inspect" store = MU.Text $ ppCStoreIn CGround msgAdd $ makeSentence [ MU.SubjectVerbSg subject verb , "an item", store ] IK.SendFlying{} -> actorVerbMU aid b "be sent flying" IK.PushActor{} -> actorVerbMU aid b "be pushed" IK.PullActor{} -> actorVerbMU aid b "be pulled" IK.DropBestWeapon -> actorVerbMU aid b "be disarmed" IK.ActivateInv{} -> return () IK.ApplyPerfume -> msgAdd "The fragrance quells all scents in the vicinity." IK.OneOf{} -> return () IK.OnSmash{} -> assert `failure` sfx IK.Recharging{} -> assert `failure` sfx IK.Temporary t -> actorVerbMU aid b $ MU.Text t 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 @timeCutOff@ --TODO -- 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. localTime <- getsState $ getLocalTime (blid b) timeCutOff <- getsClient $ EM.findWithDefault timeZero arena . sdisplayed when (localTime >= timeShift timeCutOff (Delta timeClip) --TODO || btime b >= timeShiftFromSpeed b activeItems timeCutOff || actorNewBorn b || actorDying b) $ do -- 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 = isAIFact fact unless (Just aid == mleader && not underAI) $ do -- 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. -- If considerable time passed, show delay. TODO: do this more -- accurately --- check if, eg., projectiles generated enough -- frames to cover the delay and if not, add here, too. -- Right now, if even one projectile flies, the whole 4-clip delay -- is skipped. let delta = localTime `timeDeltaToFrom` timeCutOff when (delta > Delta timeClip && not (bproj b)) displayDelay let ageDisp = EM.insert arena localTime modifyClient $ \cli -> cli {sdisplayed = ageDisp $ sdisplayed cli} unless (bproj b) $ -- projectiles display animations instead displayPush "" setLastSlot :: MonadClientUI m => ActorId -> ItemId -> CStore -> m () setLastSlot aid iid cstore = do mleader <- getsClient _sleader when (Just aid == mleader) $ do (itemSlots, _) <- getsClient sslots case lookup iid $ map swap $ EM.assocs itemSlots of Just l -> modifyClient $ \cli -> cli { slastSlot = l , slastStore = cstore } Nothing -> assert `failure` (iid, cstore, aid) strike :: MonadClientUI m => ActorId -> ActorId -> ItemId -> CStore -> HitAtomic -> m () strike source target iid cstore 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 localTime <- getsState $ getLocalTime (blid sb) bag <- getsState $ getActorBag source cstore let kit = EM.findWithDefault (1, []) iid bag itemFull = itemToF iid kit verb = case itemDisco itemFull of Nothing -> "hit" -- not identified Just ItemDisco{itemKind} -> IK.iverbHit itemKind isOrgan = iid `EM.member` borgan sb partItemChoice = if isOrgan then partItemWownW spronoun COrgan localTime else partItemAW cstore localTime msg HitClear = makeSentence $ [MU.SubjectVerbSg spart verb, tpart] ++ if bproj sb then [] else ["with", partItemChoice itemFull] msg (HitBlock n) = -- This sounds funny when the victim falls down immediately, -- 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. let sActs = if bproj sb then [ MU.SubjectVerbSg spart "connect" ] else [ MU.SubjectVerbSg spart "swing" , partItemChoice itemFull ] in makeSentence [ MU.Phrase sActs <> ", 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 LambdaHack-0.5.0.0/Game/LambdaHack/Client/UI/HandleHumanLocalClient.hs0000644000000000000000000004270412555256425023236 0ustar0000000000000000-- | 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 , selectActorHuman, selectNoneHuman, clearHuman , stopIfTgtModeHuman, selectWithPointer, repeatHuman, recordHuman , historyHuman, markVisionHuman, markSmellHuman, markSuspectHuman , helpHuman, mainMenuHuman, macroHuman -- * Commands specific to targeting , moveCursorHuman, tgtFloorHuman, tgtEnemyHuman , tgtAscendHuman, epsIncrHuman, tgtClearHuman , cursorUnknownHuman, cursorItemHuman, cursorStairHuman , cancelHuman, acceptHuman , cursorPointerFloorHuman, cursorPointerEnemyHuman , tgtPointerFloorHuman, tgtPointerEnemyHuman ) 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.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.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.Time import qualified Game.LambdaHack.Content.ItemKind as IK import Game.LambdaHack.Content.RuleKind import qualified Game.LambdaHack.Content.TileKind as TK -- * GameDifficultyCycle gameDifficultyCycle :: MonadClientUI m => m () gameDifficultyCycle = do snxtDiff <- getsClient snxtDiff let d = if snxtDiff >= difficultyBound then 1 else snxtDiff + 1 modifyClient $ \cli -> cli {snxtDiff = d} msgAdd $ "Next game difficulty set to" <+> tshow d <> "." -- * PickLeader pickLeaderHuman :: MonadClientUI m => Int -> m Slideshow pickLeaderHuman k = do side <- getsClient sside fact <- getsState $ (EM.! side) . sfactionD arena <- getArenaUI mhero <- getsState $ tryFindHeroK side k allA <- getsState $ EM.assocs . sactorD let mactor = let factionA = filter (\(_, body) -> not (bproj body) && bfid body == side) allA hs = sortBy (comparing keySelected) factionA in case drop k hs of [] -> Nothing aidb : _ -> Just aidb mchoice = mhero `mplus` mactor (autoDun, autoLvl) = autoDungeonLevel fact case mchoice of Nothing -> failMsg "no such member of the party" Just (aid, b) | blid b /= arena && autoDun -> failMsg $ showReqFailure NoChangeDunLeader | autoLvl -> failMsg $ showReqFailure NoChangeLvlLeader | otherwise -> 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 -- * 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 () selectActorHuman = do leader <- getLeaderUI selectAidHuman leader selectAidHuman :: MonadClientUI m => ActorId -> m () selectAidHuman leader = do body <- getsState $ getActorBody leader wasMemeber <- getsClient $ ES.member leader . sselected let upd = if wasMemeber then ES.delete leader -- already selected, deselect instead else ES.insert leader modifyClient $ \cli -> cli {sselected = upd $ sselected cli} let subject = partActor body msgAdd $ makeSentence [subject, if wasMemeber then "deselected" else "selected"] -- * 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 () -- * StopIfTgtMode stopIfTgtModeHuman :: MonadClientUI m => m () stopIfTgtModeHuman = do tgtMode <- getsClient stgtMode when (isJust tgtMode) stopPlayBack -- * SelectWithPointer selectWithPointer:: MonadClientUI m => m () selectWithPointer = do km <- getsClient slastKM lidV <- viewedLevel Level{lysize} <- getLevel lidV side <- getsClient sside ours <- getsState $ filter (not . bproj . snd) . actorAssocs (== side) lidV -- Select even if no space in status line for the actor's symbol. let viewed = sortBy (comparing keySelected) ours case K.pointer km of Just(Point{..}) | py == lysize + 1 && px <= length viewed && px >= 0 -> do if px == 0 then selectNoneHuman else selectAidHuman $ fst $ viewed !! (px - 1) stopPlayBack _ -> 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 <+> "actions." -- no MU, poweruser _ -> do let slastRecord = (seqPrevious, [], 0) modifyClient $ \cli -> cli {slastRecord} promptToSlideshow $ "Macro recording interrupted after" <+> tshow (maxK - k - 1) <+> "actions." -- * History historyHuman :: MonadClientUI m => m Slideshow historyHuman = do history <- getsClient shistory arena <- getArenaUI local <- getsState $ getLocalTime arena global <- getsState stime let turnsGlobal = global `timeFitUp` timeTurn turnsLocal = local `timeFitUp` timeTurn msg = makeSentence [ "You survived for" , MU.CarWs turnsGlobal "half-second turn" , "(this level:" , MU.Text (tshow turnsLocal) <> ")" ] <+> "Past messages:" overlayToBlankSlideshow False 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 -- @condBFS@ depends on the setting we change here. modifyClient $ \cli -> cli {sbfsD = EM.empty} modifyClient toggleMarkSuspect cur <- getsClient smarkSuspect msgAdd $ "Suspect terrain display toggled" <+> if cur then "on." else "off." -- * Help -- | Display command help. helpHuman :: MonadClientUI m => m Slideshow helpHuman = do keyb <- askBinding return $! keyHelp keyb -- * MainMenu -- TODO: merge with the help screens better -- | Display the main menu. mainMenuHuman :: MonadClientUI m => m Slideshow mainMenuHuman = do Kind.COps{corule} <- getsState scops escAI <- getsClient sescAI Binding{brevMap, bcmdList} <- askBinding scurDiff <- getsClient scurDiff snxtDiff <- getsClient snxtDiff 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 [ if escAI == EscAIMenu then (fst (revLookup HumanCmd.Automate), "back to screensaver") else (fst (revLookup HumanCmd.Cancel), "back to playing") , (fst (revLookup HumanCmd.Accept), "see more help") ] ++ cmds ++ [ (fst ( revLookup HumanCmd.GameDifficultyCycle) , "next game difficulty" <+> tshow snxtDiff <+> "(current" <+> tshow scurDiff <> ")" ) ] 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 True 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 -- in InventoryClient -- * TgtFloor -- in InventoryClient -- * TgtEnemy -- in InventoryClient -- * 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 (TK.Cause $ IK.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 let !_A = assert (nln /= lidV `blame` "stairs looped" `twith` nln) () nlvl <- getLevel nln -- Do not freely reveal the other end of the stairs. let ascDesc (TK.Cause (IK.Ascend _)) = True ascDesc _ = False scursor = if any ascDesc $ TK.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 False 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 False -- * EpsIncr -- in InventoryClient -- * TgtClear -- in InventoryClient -- * CursorUnknown cursorUnknownHuman :: MonadClientUI m => m Slideshow cursorUnknownHuman = 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 False -- * CursorItem cursorItemHuman :: MonadClientUI m => m Slideshow cursorItemHuman = 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 False -- * CursorStair cursorStairHuman :: MonadClientUI m => Bool -> m Slideshow cursorStairHuman up = do leader <- getLeaderUI b <- getsState $ getActorBody leader stairs <- closestTriggers (Just up) leader case sortBy (flip compare) $ runFrequency 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 False -- * 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 "target not set" -- * 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] -- * CursorPointerFloor cursorPointerFloorHuman :: MonadClientUI m => m () cursorPointerFloorHuman = do look <- cursorPointerFloor False False let !_A = assert (look == mempty `blame` look) () modifyClient $ \cli -> cli {stgtMode = Nothing} -- * CursorPointerEnemy cursorPointerEnemyHuman :: MonadClientUI m => m () cursorPointerEnemyHuman = do look <- cursorPointerEnemy False False let !_A = assert (look == mempty `blame` look) () modifyClient $ \cli -> cli {stgtMode = Nothing} -- * TgtPointerFloor tgtPointerFloorHuman :: MonadClientUI m => m Slideshow tgtPointerFloorHuman = cursorPointerFloor True False -- * TgtPointerEnemy tgtPointerEnemyHuman :: MonadClientUI m => m Slideshow tgtPointerEnemyHuman = cursorPointerEnemy True False LambdaHack-0.5.0.0/Game/LambdaHack/Client/UI/Content/0000755000000000000000000000000012555256425020007 5ustar0000000000000000LambdaHack-0.5.0.0/Game/LambdaHack/Client/UI/Content/KeyKind.hs0000644000000000000000000000163012555256425021701 0ustar0000000000000000-- | The type of key-command mappings to be used for the UI. module Game.LambdaHack.Client.UI.Content.KeyKind ( KeyKind(..) , macroLeftButtonPress, macroShiftLeftButtonPress ) 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 } macroLeftButtonPress :: HumanCmd macroLeftButtonPress = Macro "go to pointer for 100 steps" [ "ALT-space", "ALT-minus" , "SHIFT-MiddleButtonPress", "CTRL-semicolon" , "CTRL-period", "V" ] macroShiftLeftButtonPress :: HumanCmd macroShiftLeftButtonPress = Macro "run collectively to pointer for 100 steps" [ "ALT-space" , "SHIFT-MiddleButtonPress", "CTRL-colon" , "CTRL-period", "V" ] LambdaHack-0.5.0.0/Game/LambdaHack/Client/UI/Frontend/0000755000000000000000000000000012555256425020154 5ustar0000000000000000LambdaHack-0.5.0.0/Game/LambdaHack/Client/UI/Frontend/Std.hs0000644000000000000000000000561412555256425021250 0ustar0000000000000000-- | 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 -> 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 $ Just frame nextEvent keyTranslate :: Char -> K.KM keyTranslate e = (\(key, modifier) -> K.toKM 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) LambdaHack-0.5.0.0/Game/LambdaHack/Client/UI/Frontend/Vty.hs0000644000000000000000000001402012555256425021267 0ustar0000000000000000-- | 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.Concurrent.STM as STM import qualified Control.Exception as Ex hiding (handle) import Control.Monad import Data.Default import Data.Maybe 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 , schanKey :: !(STM.TQueue K.KM) -- ^ channel for keyboard input , sescMVar :: !(Maybe (MVar ())) , sdebugCli :: !DebugModeCli -- ^ client configuration } -- | 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 def schanKey <- STM.atomically STM.newTQueue escMVar <- newEmptyMVar let sess = FrontendSession{sescMVar = Just escMVar, ..} void $ async $ storeKeys sess a <- async $ k sess `Ex.finally` Vty.shutdown svty wait a storeKeys :: FrontendSession -> IO () storeKeys sess@FrontendSession{..} = do e <- nextEvent svty -- blocks here, so no polling case e of EvKey n mods -> do let !key = keyTranslate n !modifier = modifierTranslate mods !pointer = Nothing readAll = do res <- STM.atomically $ STM.tryReadTQueue schanKey when (isJust res) readAll -- If ESC, also mark it specially and reset the key channel. case sescMVar of Just escMVar -> when (key == K.Esc) $ do void $ tryPutMVar escMVar () readAll Nothing -> return () -- Store the key in the channel. STM.atomically $ STM.writeTQueue schanKey K.KM{..} _ -> return () storeKeys sess -- | Output to the screen via the frontend. fdisplay :: FrontendSession -- ^ frontend session data -> Maybe SingleFrame -- ^ the screen frame to draw -> IO () fdisplay _ Nothing = return () fdisplay FrontendSession{svty} (Just rawSF) = let SingleFrame{sfLevel} = overlayOverlay rawSF img = (foldr (<->) emptyImage . map (foldr (<|>) emptyImage . map (\ Color.AttrChar{..} -> char (setAttr acAttr) acChar))) $ map decodeLine sfLevel pic = picForImage img in update svty pic -- | Input key via the frontend. nextKeyEvent :: FrontendSession -> IO K.KM nextKeyEvent FrontendSession{..} = do km <- STM.atomically $ STM.readTQueue 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 return () _ -> -- Show the last non-empty frame and empty the queue. -- trimFrameState sess return () return km fsyncFrames :: FrontendSession -> IO () fsyncFrames _ = return () -- | Display a prompt, wait for any key. fpromptGetKey :: FrontendSession -> SingleFrame -> IO K.KM fpromptGetKey sess frame = do fdisplay sess $ Just frame nextKeyEvent sess -- TODO: Ctrl-m is RET keyTranslate :: Key -> K.Key keyTranslate n = case n of KEsc -> K.Esc KEnter -> K.Return (KChar ' ') -> K.Space (KChar '\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 KCenter -> K.Begin KIns -> K.Insert -- Ctrl-Home and Ctrl-End are the same in vty as Home and End -- on some terminals so we have to use 1--9 for movement instead of -- leader change. (KChar c) | c `elem` ['1'..'9'] -> K.KP c -- movement, not leader change | otherwise -> K.Char c _ -> K.Unknown (tshow n) -- | Translates modifiers to our own encoding. modifierTranslate :: [Modifier] -> K.Modifier modifierTranslate mods | MCtrl `elem` mods = K.Control | MAlt `elem` mods = K.Alt | MShift `elem` mods = K.Shift | otherwise = K.NoModifier -- A hack to get bright colors via the bold attribute. Depending on terminal -- settings this is needed or not and the characters really get bold or not. -- HSCurses does this by default, but in Vty you have to request the hack. hack :: Color.Color -> Attr -> Attr hack c a = if Color.isBright c then withStyle 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 $ defAttr { attrForeColor = SetTo (aToc fg) , attrBackColor = 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 = brightBlack aToc Color.BrRed = brightRed aToc Color.BrGreen = brightGreen aToc Color.BrYellow = brightYellow aToc Color.BrBlue = brightBlue aToc Color.BrMagenta = brightMagenta aToc Color.BrCyan = brightCyan aToc Color.BrWhite = brightWhite LambdaHack-0.5.0.0/Game/LambdaHack/Client/UI/Frontend/Chosen.hs0000644000000000000000000000413712555256425021734 0ustar0000000000000000{-# 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 :: 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 } LambdaHack-0.5.0.0/Game/LambdaHack/Client/UI/Frontend/Gtk.hs0000644000000000000000000005137212555256425021245 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-unused-do-bind #-} -- | Text frontend based on Gtk. 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.Applicative import Control.Concurrent import Control.Concurrent.Async import qualified Control.Concurrent.STM as STM import qualified Control.Exception as Ex hiding (handle) 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 Data.String (IsString (..)) import qualified Data.Text as T 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 import Game.LambdaHack.Common.Point 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 :: !(STM.TQueue 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, ..} FNone -> 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 <- M.fromList <$> mapM (\ ak -> do tt <- textTagNew Nothing textTagTableAdd ttt tt doAttr sdebugCli 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 <- STM.atomically STM.newTQueue -- 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. -- TODO: mainQuit somehow never called. aPoll <- async $ pollFramesAct sess `Ex.finally` postGUISync mainQuit link aPoll let flushChanKey = do res <- STM.atomically $ STM.tryReadTQueue schanKey when (isJust res) flushChanKey -- Fill the keyboard channel. sview `on` keyPressEvent $ do n <- eventKeyName mods <- eventModifier #if MIN_VERSION_gtk(0,13,0) let !key = K.keyTranslate $ T.unpack n #else let !key = K.keyTranslate n #endif !modifier = let md = modifierTranslate mods in if md == K.Shift then K.NoModifier else md !pointer = Nothing liftIO $ do unless (deadKey n) $ do -- If ESC, also mark it specially and reset the key channel. when (key == K.Esc) $ do void $ tryPutMVar escMVar () flushChanKey -- Store the key in the channel. STM.atomically $ STM.writeTQueue schanKey K.KM{..} return True -- Set the font specified in config, if any. f <- fontDescriptionFromString $ fromMaybe "" sfont widgetModifyFont sview (Just f) liftIO $ do textViewSetLeftMargin sview 3 textViewSetRightMargin sview 3 -- Prepare font chooser dialog. currentfont <- newIORef f Just display <- displayGetDefault -- TODO: change cursor depending on targeting mode, etc.; hard cursor <- cursorNewForDisplay display Tcross -- Target Crosshair Arrow sview `on` buttonPressEvent $ do liftIO flushChanKey but <- eventButton (wx, wy) <- eventCoordinates mods <- eventModifier let !modifier = modifierTranslate mods -- Shift included liftIO $ do when (but == RightButton && modifier == K.Control) $ do fsd <- fontSelectionDialogNew ("Choose font" :: String) cf <- readIORef currentfont fds <- fontDescriptionToString cf fontSelectionDialogSetFontName fsd (fds :: String) fontSelectionDialogSetPreviewText fsd ("eee...@.##+##" :: String) resp <- dialogRun fsd when (resp == ResponseOk) $ do fn <- fontSelectionDialogGetFontName fsd case fn :: Maybe String of Just fn' -> do fd <- fontDescriptionFromString fn' writeIORef currentfont fd widgetModifyFont sview (Just fd) Nothing -> return () widgetDestroy fsd -- We shouldn't pass on the click if the user has selected something. hasSelection <- textBufferHasSelection tb unless hasSelection $ do mdrawWin <- displayGetWindowAtPointer display let setCursor (drawWin, _, _) = drawWindowSetCursor drawWin (Just cursor) maybe (return ()) setCursor mdrawWin (bx, by) <- textViewWindowToBufferCoords sview TextWindowText (round wx, round wy) (iter, _) <- textViewGetIterAtPosition sview bx by cx <- textIterGetLineOffset iter cy <- textIterGetLine iter let !key = case but of LeftButton -> K.LeftButtonPress MiddleButton -> K.MiddleButtonPress RightButton -> K.RightButtonPress _ -> K.LeftButtonPress !pointer = Just $! Point cx (cy - 1) -- Store the mouse even coords in the keypress channel. STM.atomically $ STM.writeTQueue schanKey K.KM{..} return $! but == RightButton -- not to disable selection -- 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 = 30 -- | 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 FNone -> 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 -> Maybe SingleFrame -> IO () pushFrame sess 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 && isJust rawFrame then fs -- old news else FPushed{fpushed = writeLQueue fpushed nextFrame, ..} FNone | immediate -> do -- If the frame not repeated, draw it. maybe (return ()) (postGUIAsync . output sess) nextFrame -- Frame sent, we may now safely release the queue lock. putMVar sframeState FNone FNone -> putMVar sframeState $ if isNothing nextFrame && anyFollowed && isJust rawFrame then fs -- old news else FPushed{ fpushed = writeLQueue newLQueue nextFrame , fshown = dummyFrame } case nextFrame of Nothing -> putMVar slastFull (lastFrame, not (case fs of FNone -> True FPushed{} -> False && immediate && not anyFollowed)) Just f -> putMVar slastFull (f, False) 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. -- The comparison is very rarely true, because that means -- the screen looks the same as a few moves before. -- Still, we want the invariant that frames are never repeated. let lastFrame = fshown nextFrame = if frame == lastFrame then Nothing -- no sense repeating else Just frame -- Draw the last frame ASAP. maybe (return ()) (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 -> Maybe SingleFrame -- ^ the screen frame to draw -> IO () fdisplay sess = pushFrame sess False -- Display all queued frames, synchronously. displayAllFramesSync :: FrontendSession -> FrameState -> IO () displayAllFramesSync sess@FrontendSession{sdebugCli=DebugModeCli{..}, sescMVar} fs = do escPressed <- case sescMVar of Nothing -> return False Just escMVar -> not <$> isEmptyMVar escMVar let maxFps = fromMaybe defaultMaxFps smaxFps case fs of _ | escPressed -> return () 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 () FNone -> -- 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 $ Just frame km <- STM.atomically $ STM.readTQueue 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 :: (Eq t, IsString t) => t -> 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 | Control `elem` mods = K.Control | any (`elem` mods) [Meta, Super, Alt, Alt2, Alt3, Alt4, Alt5] = K.Alt | Shift `elem` mods = K.Shift | otherwise = K.NoModifier doAttr :: DebugModeCli -> TextTag -> Color.Attr -> IO () doAttr sdebugCli tt attr@Color.Attr{fg, bg} | attr == Color.defAttr = return () | fg == Color.defFG = set tt $ extraAttr sdebugCli ++ [textTagBackground := Color.colorToRGB bg] | bg == Color.defBG = set tt $ extraAttr sdebugCli ++ [textTagForeground := Color.colorToRGB fg] | otherwise = set tt $ extraAttr sdebugCli ++ [ textTagForeground := Color.colorToRGB fg , textTagBackground := Color.colorToRGB bg ] extraAttr :: DebugModeCli -> [AttrOp TextTag] extraAttr DebugModeCli{scolorIsBold} = [textTagWeight := fromEnum WeightBold | scolorIsBold == Just True] -- , textTagStretch := StretchUltraExpanded LambdaHack-0.5.0.0/Game/LambdaHack/Client/UI/Frontend/Curses.hs0000644000000000000000000001526412555256425021764 0ustar0000000000000000-- | 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 -> 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 $ Just frame nextEvent keyTranslate :: C.Key -> K.KM keyTranslate e = (\(key, modifier) -> K.toKM modifier key) $ 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) C.KeyIC -> (K.Insert, K.NoModifier) -- No KP_ keys; see -- 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 LambdaHack-0.5.0.0/Game/LambdaHack/Client/AI/0000755000000000000000000000000012555256425016351 5ustar0000000000000000LambdaHack-0.5.0.0/Game/LambdaHack/Client/AI/PickActorClient.hs0000644000000000000000000003135712555256425021734 0ustar0000000000000000{-# LANGUAGE TupleSections #-} -- | Semantics of most 'ResponseAI' client commands. module Game.LambdaHack.Client.AI.PickActorClient ( pickActorToMove ) 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.ConditionClient import Game.LambdaHack.Client.AI.PickTargetClient 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 Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.Frequency 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.Random import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile import Game.LambdaHack.Common.Vector import Game.LambdaHack.Content.ModeKind pickActorToMove :: MonadClient m => ((ActorId, Actor) -> m (Maybe (Target, PathEtc))) -> ActorId -> m (ActorId, Actor) pickActorToMove refreshTarget oldAid = do 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 explore = void $ refreshTarget (oldAid, oldBody) setPath mtgt = case mtgt of Nothing -> return False Just (tgtLeader, _) -> do mpath <- createPath oldAid tgtLeader case mpath of Nothing -> return False Just path -> do let tgtMPath = second Just path modifyClient $ \cli -> cli {stargetD = EM.alter (const $ Just tgtMPath) oldAid (stargetD cli)} return True follow = case mleader of -- If no leader at all (forced @TFollow@ tactic on an actor -- from a leaderless faction), fall back to @TExplore@. Nothing -> explore Just leader -> do onLevel <- getsState $ memActor leader arena -- If leader not on this level, fall back to @TExplore@. if not onLevel then explore else do modifyClient $ \cli -> cli { sbfsD = invalidateBfs oldAid (sbfsD cli) , seps = seps cli + 773 } -- randomize paths -- Copy over the leader's target, if any, or follow his bpos. mtgt <- getsClient $ EM.lookup leader . stargetD tgtPathSet <- setPath mtgt let enemyPath = Just (TEnemy leader True, Nothing) unless tgtPathSet $ do enemyPathSet <- setPath enemyPath unless enemyPathSet $ -- If no path even to the leader himself, explore. explore pickOld = do if mleader == Just oldAid then explore else case ftactic $ gplayer fact of TExplore -> explore TFollow -> follow TFollowNoItems -> follow TMeleeAndRanged -> explore -- needs to find ranged targets TMeleeAdjacent -> explore -- probably not needed, but may change TBlock -> return () -- no point refreshing target TRoam -> explore -- @TRoam@ is checked again inside @explore@ TPatrol -> explore -- TODO return (oldAid, oldBody) case ours of _ | -- Keep the leader: only a leader is allowed to pick another leader. mleader /= Just oldAid -- Keep the leader: the faction forbids client leader change on level. || snd (autoDungeonLevel 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. let refresh aidBody = do mtgt <- refreshTarget aidBody return $! (aidBody,) <$> mtgt oursTgt <- catMaybes <$> mapM refresh ours let actorVulnerable ((aid, body), _) = do activeItems <- activeItemsClient aid condMeleeBad <- condMeleeBadM aid threatDistL <- threatDistList aid (fleeL, _) <- fleeList aid let actorMaxSk = sumSkills activeItems abInMaxSkill ab = EM.findWithDefault 0 ab actorMaxSk > 0 condNoUsableWeapon = all (not . isMelee) activeItems canMelee = abInMaxSkill AbMelee && not condNoUsableWeapon condCanFlee = not (null fleeL) condThreatAtHandVeryClose = not $ null $ takeWhile ((<= 2) . fst) threatDistL threatAdj = takeWhile ((== 1) . fst) threatDistL condThreatAdj = not $ null threatAdj condFastThreatAdj = any (\(_, (_, b)) -> bspeed b activeItems > bspeed body activeItems) threatAdj heavilyDistressed = -- Actor hit by a projectile or similarly distressed. deltaSerious (bcalmDelta body) return $! not (canMelee && condThreatAdj) && if condThreatAtHandVeryClose then condCanFlee && condMeleeBad && not condFastThreatAdj else heavilyDistressed -- shot at -- 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 actorMeleeBad ((aid, _), _) = do threatDistL <- threatDistList aid let condThreatMedium = -- if foes far, friends may still come not $ null $ takeWhile ((<= 5) . fst) threatDistL condMeleeBad <- condMeleeBadM aid return $! condThreatMedium && condMeleeBad oursVulnerable <- filterM actorVulnerable oursTgt oursSafe <- filterM (fmap not . actorVulnerable) oursTgt -- TODO: partitionM oursMeleeing <- filterM actorMeleeing oursSafe oursNotMeleeing <- filterM (fmap not . actorMeleeing) oursSafe oursHearing <- filterM actorHearning oursNotMeleeing oursNotHearing <- filterM (fmap not . actorHearning) oursNotMeleeing oursMeleeBad <- filterM actorMeleeBad oursNotHearing oursNotMeleeBad <- filterM (fmap not . actorMeleeBad) oursNotHearing let targetTEnemy (_, (TEnemy{}, _)) = True targetTEnemy (_, (TEnemyPos{}, _)) = True targetTEnemy _ = False (oursTEnemy, oursOther) = partition targetTEnemy oursNotMeleeBad -- 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 ++ oursMeleeBad -- 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 oursVulnerableGood = filter goodTEnemy oursVulnerable oursTEnemyGood = filter goodTEnemy oursTEnemy oursPosGood = filter goodGeneric oursPos oursMeleeingGood = filter goodGeneric oursMeleeing oursHearingGood = filter goodTEnemy oursHearing oursBlockedGood = filter goodGeneric oursBlocked candidates = [ sortOurs oursVulnerableGood , 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) LambdaHack-0.5.0.0/Game/LambdaHack/Client/AI/HandleAbilityClient.hs0000644000000000000000000013051712555256425022564 0ustar0000000000000000{-# 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 Game.LambdaHack.Common.Faction 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 qualified Game.LambdaHack.Content.ItemKind as IK import Game.LambdaHack.Content.ModeKind import qualified Game.LambdaHack.Content.TileKind as TK 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 condTgtEnemyAdjFriend <- condTgtEnemyAdjFriendM aid condAnyFoeAdj <- condAnyFoeAdjM aid threatDistL <- threatDistList aid condHpTooLow <- condHpTooLowM aid condOnTriggerable <- condOnTriggerableM aid condBlocksFriends <- condBlocksFriendsM aid condNoEqpWeapon <- condNoEqpWeaponM aid let condNoUsableWeapon = all (not . isMelee) activeItems condEnoughGear <- condEnoughGearM aid condFloorWeapon <- condFloorWeaponM aid condCanProject <- condCanProjectM False aid condNotCalmEnough <- condNotCalmEnoughM aid condDesirableFloorItem <- condDesirableFloorItemM aid condMeleeBad <- condMeleeBadM aid condTgtNonmoving <- condTgtNonmovingM aid aInAmbient <- getsState $ actorInAmbient body explored <- getsClient sexplored (fleeL, badVic) <- fleeList aid let lidExplored = ES.member (blid body) explored panicFleeL = fleeL ++ badVic actorShines = sumSlotNoFilter IK.EqpSlotAddLight activeItems > 0 condThreatAdj = not $ null $ takeWhile ((== 1) . fst) threatDistL condThreatAtHand = not $ null $ takeWhile ((<= 2) . fst) threatDistL condThreatNearby = not $ null $ takeWhile ((<= 9) . fst) threatDistL speed1_5 = speedScale (3%2) (bspeed body activeItems) condFastThreatAdj = any (\(_, (_, b)) -> bspeed b activeItems > speed1_5) $ takeWhile ((== 1) . fst) threatDistL heavilyDistressed = -- actor hit by a proj or similarly distressed deltaSerious (bcalmDelta body) let actorMaxSk = sumSkills activeItems abInMaxSkill ab = EM.findWithDefault 0 ab actorMaxSk > 0 stratToFreq :: MonadStateRead m => Int -> m (Strategy RequestAnyAbility) -> m (Frequency RequestAnyAbility) stratToFreq scale mstrat = do st <- mstrat return $! if scale == 0 then mzero else scaleFreq scale $ bestVariant st -- TODO: flatten instead? -- 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 :: [([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) ) , ( [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 && abInMaxSkill AbMelee ) , ( [AbMelee], (toAny :: ToAny 'AbMelee) <$> meleeBlocker aid -- only melee target or blocker , condAnyFoeAdj || not (abInMaxSkill AbDisplace) -- melee friends, not displace && fleaderMode (gplayer fact) == LeaderNull -- not restrained && condTgtEnemyPresent ) -- excited , ( [AbTrigger], (toAny :: ToAny 'AbTrigger) <$> trigger aid False , condOnTriggerable && not condDesirableFloorItem && (lidExplored || condEnoughGear) && not condTgtEnemyPresent ) , ( [AbMove] , flee aid fleeL , condMeleeBad && not condFastThreatAdj -- Don't keep fleeing if was just hit, unless can't melee at all. && not (heavilyDistressed && abInMaxSkill AbMelee && not condNoUsableWeapon) && condThreatAtHand ) , ( [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 || condDesirableFloorItem || condNotCalmEnough) ) ] -- Order doesn't matter, scaling does. distant :: [([Ability], m (Frequency RequestAnyAbility), Bool)] distant = [ ( [AbMoveItem] , stratToFreq 20000 $ (toAny :: ToAny 'AbMoveItem) <$> yieldUnneeded aid -- 20000 to unequip ASAP, unless is thrown , True ) , ( [AbProject] -- for high-value target, shoot even in melee , stratToFreq 2 $ (toAny :: ToAny 'AbProject) <$> projectItem aid , condTgtEnemyPresent && condCanProject && not condOnTriggerable ) , ( [AbApply] , stratToFreq 2 $ (toAny :: ToAny 'AbApply) <$> applyItem aid ApplyAll -- use any potion or scroll , (condTgtEnemyPresent || condThreatNearby) -- can affect enemies && not condOnTriggerable ) , ( [AbMove] , stratToFreq (if not condTgtEnemyPresent then 3 -- if enemy only remembered, investigate anyway else if condTgtNonmoving then 0 else if condTgtEnemyAdjFriend then 1000 -- friends probably pummeled, go to help else 100) $ chase aid True (condMeleeBad && condThreatNearby && not aInAmbient && not actorShines) , (condTgtEnemyPresent || condTgtEnemyRemembered) && not (condDesirableFloorItem && not condThreatAtHand) && abInMaxSkill AbMelee && not condNoUsableWeapon ) ] -- Order matters again. suffix = [ ( [AbMelee], (toAny :: ToAny 'AbMelee) <$> meleeAny aid -- avoid getting damaged for naught , condAnyFoeAdj ) , ( [AbMove] , flee aid panicFleeL -- ultimate panic mode, displaces foes , condAnyFoeAdj ) , ( [AbMoveItem], (toAny :: ToAny 'AbMoveItem) <$> pickup aid False , not condThreatAtHand ) -- e.g., to give to other party members , ( [AbMoveItem], (toAny :: ToAny 'AbMoveItem) <$> unEquipItems aid -- late, because these items not bad , True ) , ( [AbMove] , chase aid True (condTgtEnemyPresent -- Don't keep hiding in darkness if hit right now, -- unless can't melee at all. && not (heavilyDistressed && abInMaxSkill AbMelee && not condNoUsableWeapon) && condMeleeBad && condThreatNearby && not aInAmbient && not actorShines) , not (condTgtNonmoving && condThreatAtHand) ) -- TODO: unless tgt can't melee ] fallback = [ ( [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 -- Check current, not maximal skills, since this can be a non-leader action. actorSk <- actorSkillsClient aid let abInSkill ab = EM.findWithDefault 0 ab actorSk > 0 checkAction :: ([Ability], m a, Bool) -> Bool checkAction (abts, _, cond) = all abInSkill abts && cond sumS abAction = do let as = filter checkAction abAction strats <- mapM (\(_, m, _) -> m) as return $! msum strats sumF abFreq = do let as = filter checkAction abFreq strats <- mapM (\(_, m, _) -> m) as return $! msum strats combineDistant as = liftFrequency <$> sumF as sumPrefix <- sumS prefix comDistant <- combineDistant distant sumSuffix <- sumS suffix sumFallback <- sumS fallback return $! sumPrefix .| comDistant .| sumSuffix .| sumFallback -- | 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 b <- getsState $ getActorBody aid activeItems <- activeItemsClient 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) let calmE = calmEnough b activeItems isWeapon (_, (_, itemFull)) = isMeleeEqp itemFull filterWeapon | onlyWeapon = filter isWeapon | otherwise = id prepareOne (oldN, l4) ((_, (k, _)), (iid, itemFull)) = let n = oldN + k (newN, toCStore) | calmE && goesIntoSha itemFull = (oldN, CSha) | goesIntoEqp itemFull && eqpOverfull b n = (oldN, if calmE then CSha else CInv) | goesIntoEqp itemFull = (n, CEqp) | otherwise = (oldN, CInv) in (newN, (iid, k, CGround, toCStore) : l4) (_, prepared) = foldl' prepareOne (0, []) $ filterWeapon benItemL return $! if null prepared then reject else returN "pickup" $ ReqMoveItems prepared equipItems :: MonadClient m => ActorId -> m (Strategy (RequestTimed 'AbMoveItem)) equipItems aid = do cops <- getsState scops body <- getsState $ getActorBody aid activeItems <- activeItemsClient aid let calmE = calmEnough body activeItems fact <- getsState $ (EM.! bfid body) . sfactionD eqpAssocs <- fullAssocsClient aid [CEqp] invAssocs <- fullAssocsClient aid [CInv] shaAssocs <- fullAssocsClient aid [CSha] condAnyFoeAdj <- condAnyFoeAdjM aid condLightBetrays <- condLightBetraysM aid condTgtEnemyPresent <- condTgtEnemyPresentM aid let improve :: CStore -> (Int, [(ItemId, Int, CStore, CStore)]) -> ( IK.EqpSlot , ( [(Int, (ItemId, ItemFull))] , [(Int, (ItemId, ItemFull))] ) ) -> (Int, [(ItemId, Int, CStore, CStore)]) improve fromCStore (oldN, l4) (slot, (bestInv, bestEqp)) = let n = 1 + oldN in case (bestInv, bestEqp) of ((_, (iidInv, _)) : _, []) | not (eqpOverfull body n) -> (n, (iidInv, 1, fromCStore, CEqp) : l4) ((vInv, (iidInv, _)) : _, (vEqp, _) : _) | not (eqpOverfull body n) && (vInv > vEqp || not (toShare slot)) -> (n, (iidInv, 1, fromCStore, CEqp) : l4) _ -> (oldN, l4) -- 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 condAnyFoeAdj condLightBetrays condTgtEnemyPresent (not calmE) body activeItems fact itemFull bestThree = bestByEqpSlot (filter filterNeeded eqpAssocs) (filter filterNeeded invAssocs) (filter filterNeeded shaAssocs) bEqpInv = foldl' (improve CInv) (0, []) $ map (\((slot, _), (eqp, inv, _)) -> (slot, (inv, eqp))) bestThree bEqpBoth | calmE = foldl' (improve CSha) bEqpInv $ map (\((slot, _), (eqp, _, sha)) -> (slot, (sha, eqp))) bestThree | otherwise = bEqpInv (_, prepared) = bEqpBoth return $! if null prepared then reject else returN "equipItems" $ ReqMoveItems prepared toShare :: IK.EqpSlot -> Bool toShare IK.EqpSlotPeriodic = False toShare _ = True yieldUnneeded :: MonadClient m => ActorId -> m (Strategy (RequestTimed 'AbMoveItem)) yieldUnneeded aid = do cops <- getsState scops body <- getsState $ getActorBody aid activeItems <- activeItemsClient aid let calmE = calmEnough body activeItems fact <- getsState $ (EM.! bfid body) . sfactionD eqpAssocs <- fullAssocsClient aid [CEqp] condAnyFoeAdj <- condAnyFoeAdjM aid condLightBetrays <- condLightBetraysM aid condTgtEnemyPresent <- condTgtEnemyPresentM aid -- 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. let yieldSingleUnneeded (iidEqp, itemEqp) = let csha = if calmE then CSha else CInv in if harmful cops body activeItems fact itemEqp then [(iidEqp, itemK itemEqp, CEqp, CInv)] else if hinders condAnyFoeAdj condLightBetrays condTgtEnemyPresent (not calmE) body activeItems itemEqp then [(iidEqp, itemK itemEqp, CEqp, csha)] else [] yieldAllUnneeded = concatMap yieldSingleUnneeded eqpAssocs return $! if null yieldAllUnneeded then reject else returN "yieldUnneeded" $ ReqMoveItems yieldAllUnneeded unEquipItems :: MonadClient m => ActorId -> m (Strategy (RequestTimed 'AbMoveItem)) unEquipItems aid = do cops <- getsState scops body <- getsState $ getActorBody aid activeItems <- activeItemsClient aid let calmE = calmEnough body activeItems fact <- getsState $ (EM.! bfid body) . sfactionD eqpAssocs <- fullAssocsClient aid [CEqp] invAssocs <- fullAssocsClient aid [CInv] shaAssocs <- fullAssocsClient aid [CSha] condAnyFoeAdj <- condAnyFoeAdjM aid condLightBetrays <- condLightBetraysM aid condTgtEnemyPresent <- condTgtEnemyPresentM aid -- 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. let improve :: CStore -> ( IK.EqpSlot , ( [(Int, (ItemId, ItemFull))] , [(Int, (ItemId, ItemFull))] ) ) -> [(ItemId, Int, CStore, CStore)] improve fromCStore (slot, (bestSha, bestEOrI)) = case (bestSha, bestEOrI) of _ | not (toShare slot) && fromCStore == CEqp && not (eqpOverfull body 1) -> -- keep periodic items up to M-1 [] (_, (vEOrI, (iidEOrI, _)) : _) | (toShare slot || fromCStore == CInv) && getK bestEOrI > 1 && betterThanSha vEOrI bestSha -> -- To share the best items with others, if they care. [(iidEOrI, getK bestEOrI - 1, fromCStore, CSha)] (_, _ : (vEOrI, (iidEOrI, _)) : _) | (toShare slot || fromCStore == CInv) && betterThanSha vEOrI bestSha -> -- To share the second best items with others, if they care. [(iidEOrI, getK bestEOrI, fromCStore, CSha)] (_, (vEOrI, (_, _)) : _) | fromCStore == CEqp && eqpOverfull body 1 && worseThanSha vEOrI bestSha -> -- To make place in eqp for an item better than any ours. [(fst $ snd $ last bestEOrI, 1, fromCStore, CSha)] _ -> [] getK [] = 0 getK ((_, (_, itemFull)) : _) = itemK itemFull betterThanSha _ [] = True betterThanSha vEOrI ((vSha, _) : _) = vEOrI > vSha worseThanSha _ [] = False worseThanSha vEOrI ((vSha, _) : _) = vEOrI < vSha filterNeeded (_, itemFull) = not $ unneeded cops condAnyFoeAdj condLightBetrays condTgtEnemyPresent (not calmE) body activeItems fact itemFull bestThree = bestByEqpSlot eqpAssocs invAssocs (filter filterNeeded shaAssocs) bInvSha = concatMap (improve CInv . (\((slot, _), (_, inv, sha)) -> (slot, (sha, inv)))) bestThree bEqpSha = concatMap (improve CEqp . (\((slot, _), (eqp, _, sha)) -> (slot, (sha, eqp)))) bestThree prepared = if calmE then bInvSha ++ bEqpSha else [] return $! if null prepared then reject else returN "unEquipItems" $ ReqMoveItems prepared groupByEqpSlot :: [(ItemId, ItemFull)] -> M.Map (IK.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)] -> [((IK.EqpSlot, Text) , ( [(Int, (ItemId, ItemFull))] , [(Int, (ItemId, ItemFull))] , [(Int, (ItemId, ItemFull))] ) )] bestByEqpSlot eqpAssocs invAssocs 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) eqpInvShaMap = M.unionsWith appendThree [eqpMap, invMap, shaMap] bestSingle = strongestSlot bestThree (eqpSlot, _) (g1, g2, g3) = (bestSingle eqpSlot g1, bestSingle eqpSlot g2, bestSingle eqpSlot g3) in M.assocs $ M.mapWithKey bestThree eqpInvShaMap 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) unneeded :: Kind.COps -> Bool -> Bool -> Bool -> Bool -> Actor -> [ItemFull] -> Faction -> ItemFull -> Bool unneeded cops condAnyFoeAdj condLightBetrays condTgtEnemyPresent condNotCalmEnough body activeItems fact itemFull = harmful cops body activeItems fact itemFull || hinders condAnyFoeAdj condLightBetrays condTgtEnemyPresent condNotCalmEnough body activeItems itemFull || let calm10 = calmEnough10 body activeItems -- unneeded risk itemLit = isJust $ strengthFromEqpSlot IK.EqpSlotAddLight itemFull in itemLit && not calm10 -- 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 actorSk <- actorSkillsClient aid 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 | adjacent (bpos b) goal = Just goal | adjacent (bpos b) q = Just q | otherwise = Nothing -- MeleeDistant lBlocker <- case maim of Nothing -> return [] Just aim -> getsState $ posToActors aim (blid b) case lBlocker of (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. && fleaderMode (gplayer fact) == LeaderNull -- no restrain && EM.findWithDefault 0 AbMove actorSk > 0 -- blocked move && bhp body2 < bhp b) -- respect power then do mel <- maybeToList <$> pickWeaponClient aid aid2 return $! liftFrequency $ uniformFreq "melee in the way" mel else 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. 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" $ catMaybes mels return $! liftFrequency freq -- TODO: take charging status into account -- TODO: make sure the stairs are specifically targetted and not -- an item on them, etc., so that we don't leave level if items visible. -- When invalidating target, make sure the stairs should really be taken. -- | 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. -- We don't verify the stairs are targeted by the actor, but at least -- the actor doesn't target a visible enemy at this point. 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 let lid = blid b lvl <- getLevel lid unexploredD <- unexploredDepth s <- getState let lidExplored = ES.member lid explored allExplored = ES.size explored == EM.size dungeon t = lvl `at` bpos b feats = TK.tfeature $ okind t ben feat = case feat of TK.Cause (IK.Ascend k) -> do -- change levels sensibly, in teams (lid2, pos2) <- getsState $ whereTo lid (bpos b) k . sdungeon per <- getPerFid lid2 let canSee = ES.member (bpos b) (totalVisible per) aimless = ftactic (gplayer fact) `elem` [TRoam, TPatrol] easier = signum k /= signum (fromEnum lid) unexpForth = unexploredD (signum k) lid unexpBack = unexploredD (- signum k) lid expBenefit | aimless = 100 -- faction is not exploring, so switch at will | unexpForth = if easier -- alway try as easy level as possible || not unexpBack && lidExplored -- no other choice for exploration then 1000 else 0 | not lidExplored = 0 -- fully explore current | unexpBack = 0 -- wait for stairs in the opposite direciton | not $ null $ lescape lvl = 0 -- all explored, stay on the escape level | otherwise = 2 -- no escape, switch levels occasionally actorsThere = posToActors pos2 lid2 s return $! if boldpos b == Just (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 _ -> min 1 expBenefit -- risk pushing in if fleeViaStairs then 1000 * eben + 1 -- strongly prefer correct direction else eben TK.Cause ef@IK.Escape{} -> return $ -- flee via this way, too -- Only some factions try to escape but they first explore all -- for high score. if not (fcanEscape $ gplayer fact) || not allExplored then 0 else effectToBenefit cops b activeItems fact ef TK.Cause ef | not fleeViaStairs -> return $! effectToBenefit cops b activeItems fact ef _ -> return 0 benFeats <- mapM ben feats let benFeat = zip benFeats feats return $! liftFrequency $ toFreq "trigger" [ (benefit, ReqTrigger (Just feat)) | (benefit, feat) <- benFeat , benefit > 0 ] projectItem :: MonadClient m => ActorId -> m (Strategy (RequestTimed 'AbProject)) projectItem aid = do btarget <- getsClient $ getTarget aid b <- getsState $ getActorBody aid mfpos <- aidTgtToPos aid (blid b) btarget seps <- getsClient seps case (btarget, mfpos) of (_, Just fpos) | chessDist (bpos b) fpos == 1 -> return reject (Just TEnemy{}, Just fpos) -> do mnewEps <- makeLine False b fpos seps case mnewEps of Just newEps -> do actorSk <- actorSkillsClient aid let skill = EM.findWithDefault 0 AbProject actorSk -- ProjectAimOnself, ProjectBlockActor, ProjectBlockTerrain -- and no actors or obstracles along the path. let q _ itemFull b2 activeItems = either (const False) id $ permittedProject " " False skill itemFull b2 activeItems activeItems <- activeItemsClient aid let calmE = calmEnough b activeItems stores = [CEqp, CInv, CGround] ++ [CSha | calmE] benList <- benAvailableItems aid q stores localTime <- getsState $ getLocalTime (blid b) let coeff CGround = 2 coeff COrgan = 3 -- can't give to others coeff CEqp = 100000 -- must hinder currently coeff CInv = 1 coeff CSha = 1 fRanged ( (mben, (_, cstore)) , (iid, itemFull@ItemFull{itemBase}) ) = -- We assume if the item has a timeout, most effects are under -- Recharging, so no point projecting if not recharged. -- This is not an obvious assumption, so recharging is not -- included in permittedProject and can be tweaked here easily. let recharged = hasCharge localTime itemFull trange = totalRange itemBase bestRange = chessDist (bpos b) fpos + 2 -- margin for fleeing rangeMult = -- penalize wasted or unsafely low range 10 + max 0 (10 - abs (trange - bestRange)) durable = IK.Durable `elem` jfeature itemBase durableBonus = if durable then 2 -- we or foes keep it after the throw else 1 benR = durableBonus * coeff cstore * case mben of Nothing -> -1 -- experiment if no options Just (_, ben) -> ben * (if recharged then 1 else 0) in if -- Durable weapon is usually too useful for melee. not (isMeleeEqp itemFull) && benR < 0 && trange >= chessDist (bpos b) fpos then Just ( -benR * rangeMult `div` 10 , ReqProject fpos newEps iid cstore ) else Nothing benRanged = mapMaybe fRanged benList return $! liftFrequency $ toFreq "projectItem" benRanged _ -> return reject _ -> return reject data ApplyItemGroup = ApplyAll | ApplyFirstAid deriving Eq applyItem :: MonadClient m => ActorId -> ApplyItemGroup -> m (Strategy (RequestTimed 'AbApply)) applyItem aid applyGroup = do actorSk <- actorSkillsClient aid b <- getsState $ getActorBody aid localTime <- getsState $ getLocalTime (blid b) let skill = EM.findWithDefault 0 AbApply actorSk q _ itemFull _ activeItems = -- TODO: terrible hack to prevent the use of identified healing gems let freq = case itemDisco itemFull of Nothing -> [] Just ItemDisco{itemKind} -> IK.ifreq itemKind in maybe True (<= 0) (lookup "gem" freq) && either (const False) id (permittedApply " " localTime skill itemFull b activeItems) activeItems <- activeItemsClient aid let calmE = calmEnough b activeItems stores = [CEqp, CInv, CGround] ++ [CSha | calmE] benList <- benAvailableItems aid q stores organs <- mapM (getsState . getItemBody) $ EM.keys $ borgan b let itemLegal itemFull = case applyGroup of ApplyFirstAid -> let getP (IK.RefillHP p) _ | p > 0 = True getP (IK.OverfillHP 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 = 100000 -- must hinder currently coeff CInv = 1 coeff CSha = 1 fTool ((mben, (_, cstore)), (iid, itemFull@ItemFull{itemBase})) = let durableBonus = if IK.Durable `elem` jfeature itemBase then 5 -- we keep it after use else 1 oldGrps = map (toGroupName . jname) organs createOrganAgain = -- This assumes the organ creation is beneficial. If it's -- a drawback of an otherwise good item, we should reverse -- the condition. let newGrps = strengthCreateOrgan itemFull in not $ null $ intersect newGrps oldGrps dropOrganVoid = -- This assumes the organ dropping is beneficial. If it's -- a drawback of an otherwise good item, or a marginal -- advantage only, we should reverse or ignore the condition. -- We ignore a very general @grp@ being used for a very -- common and easy to drop organ, etc. let newGrps = strengthDropOrgan itemFull hasDropOrgan = not $ null newGrps in hasDropOrgan && null (newGrps `intersect` oldGrps) benR = case mben of Nothing -> 0 -- experimenting is fun, but it's better to risk -- foes' skin than ours -- TODO: when {applied} -- is implemented, enable this for items too heavy, -- etc. for throwing Just (_, ben) -> ben * (if not createOrganAgain then 1 else 0) * (if not dropOrganVoid then 1 else 0) * durableBonus * coeff cstore in if itemLegal itemFull && benR > 0 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. -- 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 displaceable body = -- DisplaceAccess adjacent (bpos body) (bpos b) && accessibleHere (bpos body) 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 -- DisplaceDying, DisplaceBraced, DisplaceImmobile, DisplaceSupported 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 let !_A = assert (source == bpos b && adjacent source target) () lvl <- getLevel $ blid b if boldpos b /= Just target -- avoid trivial loops && accessible cops lvl source target then do -- DisplaceAccess mleader <- getsClient _sleader mBlocker <- getsState $ posToActors target (blid b) case mBlocker of [] -> return reject [(aid2, b2)] | Just aid2 /= mleader -> do mtgtMPath <- getsClient $ EM.lookup aid2 . stargetD case mtgtMPath of Just (tgt, Just (p : q : rest, (goal, len))) | q == source && p == target || waitedLastTurn b2 -> do let newTgt = if q == source && p == target then Just (tgt, Just (q : rest, (goal, len - 1))) else Nothing 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, etc. _ -> return reject -- DisplaceProjectiles or trying to displace leader else return reject chase :: MonadClient m => ActorId -> Bool -> Bool -> m (Strategy RequestAnyAbility) chase aid doDisplace avoidAmbient = do Kind.COps{cotile} <- getsState scops body <- getsState $ getActorBody aid fact <- getsState $ (EM.! bfid body) . sfactionD mtgtMPath <- getsClient $ EM.lookup aid . stargetD lvl <- getLevel $ blid body let isAmbient pos = Tile.isLit cotile (lvl `at` pos) str <- case mtgtMPath of Just (_, Just (p : q : _, (goal, _))) | not $ avoidAmbient && isAmbient q -> -- With no leader, the goal is vague, so permit arbitrary detours. moveTowards aid p q goal (fleaderMode (gplayer fact) == LeaderNull) _ -> 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 -- TODO: rename source here and elsewhere, it's always an ActorId in the code 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 actorSk <- actorSkillsClient aid let alterSkill = EM.findWithDefault 0 AbAlter actorSk !_A = assert (source == bpos b `blame` (source, bpos b, aid, b, goal)) () !_B = assert (adjacent source target `blame` (source, target, aid, b, goal)) () 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 -- Only actors with AbAlter can search for hidden doors, etc. bumpableHere p = let t = lvl `at` p in alterSkill >= 1 && (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 = maybe False (\oldpos -> v == oldpos `vectorToFrom` source) (boldpos b) 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 actorSk <- actorSkillsClient source let lid = blid sb lvl <- getLevel lid let skill = EM.findWithDefault 0 AbAlter actorSk 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 -- @target@ 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 == Just tpos && not (waitedLastTurn sb) -- avoid Displace loops || not (accessible cops lvl spos tpos) -- DisplaceAccess then return Nothing else if isAtWar tfact (bfid sb) && not dEnemy -- DisplaceDying, etc. then do wps <- pickWeaponClient source target case wps of Nothing -> return Nothing Just wp -> return $! Just $ RequestAnyAbility wp else return $! Just $ RequestAnyAbility $ ReqDisplace target (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 Nothing -> return Nothing Just wp -> return $! Just $ RequestAnyAbility wp [] -- move or search or alter | accessible cops lvl spos tpos -> -- Movement requires full access. return $! Just $ RequestAnyAbility $ ReqMove dir -- The potential invisible actor is hit. | skill < 1 -> assert `failure` "AI causes AlterUnskilled" `twith` (run, source, dir) | EM.member tpos $ lfloor lvl -> -- This could be, e.g., inaccessible open door with an item in it, -- but for this case to happen, it would also need to be unwalkable. assert `failure` "AI causes AlterBlockItem" `twith` (run, source, dir) | not (Tile.isWalkable cotile t) -- not implied && (Tile.isSuspect cotile t || Tile.isOpenable cotile t || Tile.isClosable cotile t || Tile.isChangeable cotile t) -> -- No access, so search and/or alter the tile. return $! Just $ RequestAnyAbility $ ReqAlter tpos Nothing | otherwise -> -- Boring tile, no point bumping into it, do WaitSer if really idle. assert `failure` "AI causes MoveNothing or AlterNothing" `twith` (run, source, dir) LambdaHack-0.5.0.0/Game/LambdaHack/Client/AI/ConditionClient.hs0000644000000000000000000003756012555256425022005 0ustar0000000000000000-- | 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 , condTgtEnemyAdjFriendM , condTgtNonmovingM , condAnyFoeAdjM , condHpTooLowM , condOnTriggerableM , condBlocksFriendsM , condFloorWeaponM , condNoEqpWeaponM , condEnoughGearM , condCanProjectM , condNotCalmEnoughM , condDesirableFloorItemM , condMeleeBadM , condLightBetraysM , benAvailableItems , hinders , benGroundItems , desirableItem , 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 qualified Game.LambdaHack.Common.Ability as Ability import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState 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.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 qualified Game.LambdaHack.Content.ItemKind as IK -- | 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 _ permit) -> not permit _ -> 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 _ permit) | lid == blid b -> not permit _ -> False -- | Require that the target enemy is adjacent to at least one friend. condTgtEnemyAdjFriendM :: MonadClient m => ActorId -> m Bool condTgtEnemyAdjFriendM aid = do btarget <- getsClient $ getTarget aid case btarget of Just (TEnemy enemy _) -> do be <- getsState $ getActorBody enemy b <- getsState $ getActorBody aid fact <- getsState $ (EM.! bfid b) . sfactionD let friendlyFid fid = fid == bfid b || isAllied fact fid friends <- getsState $ actorRegularList friendlyFid (blid b) return $ any (adjacent (bpos be) . bpos) friends -- keep it lazy _ -> return False -- | Check if the target is nonmoving. condTgtNonmovingM :: MonadClient m => ActorId -> m Bool condTgtNonmovingM aid = do btarget <- getsClient $ getTarget aid case btarget of Just (TEnemy enemy _) -> do activeItems <- activeItemsClient enemy let actorMaxSkE = sumSkills activeItems return $! EM.findWithDefault 0 Ability.AbMove actorMaxSkE <= 0 _ -> return 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 let actorMaxSkE = sumSkills activeItems nonmoving = EM.findWithDefault 0 Ability.AbMove actorMaxSkE <= 0 return $! not (hpTooLow b2 activeItems || nonmoving) 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 that would be auto-equipped. condFloorWeaponM :: MonadClient m => ActorId -> m Bool condFloorWeaponM aid = do floorAssocs <- fullAssocsClient aid [CGround] let lootIsWeapon = any (isMeleeEqp . snd) 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] return $ all (not . isMelee . snd) allAssocs -- keep it lazy -- | Check whether the actor has enough gear to go look for enemies. condEnoughGearM :: MonadClient m => ActorId -> m Bool condEnoughGearM aid = do eqpAssocs <- fullAssocsClient aid [CEqp] invAssocs <- fullAssocsClient aid [CInv] return $ any (isMelee . snd) eqpAssocs || length (eqpAssocs ++ invAssocs) >= 5 -- keep it lazy -- | Require that the actor can project any items. condCanProjectM :: MonadClient m => Bool -> ActorId -> m Bool condCanProjectM maxSkills aid = do actorSk <- if maxSkills then do activeItems <- activeItemsClient aid return $! sumSkills activeItems else actorSkillsClient aid let skill = EM.findWithDefault 0 Ability.AbProject actorSk q _ itemFull b activeItems = either (const False) id $ permittedProject " " False skill itemFull b activeItems benList <- benAvailableItems aid q [CEqp, CInv, CGround] let missiles = filter (maybe True ((< 0) . snd) . fst . fst) benList return $ 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 -> (Maybe Int -> ItemFull -> Actor -> [ItemFull] -> Bool) -> [CStore] -> m [( (Maybe (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 condAnyFoeAdj <- condAnyFoeAdjM aid condLightBetrays <- condLightBetraysM aid condTgtEnemyPresent <- condTgtEnemyPresentM aid condNotCalmEnough <- condNotCalmEnoughM aid let ben cstore bag = [ ((benefit, (k, cstore)), (iid, itemFull)) | (iid, kit@(k, _)) <- EM.assocs bag , let itemFull = itemToF iid kit benefit = totalUsefulness cops b activeItems fact itemFull hind = hinders condAnyFoeAdj condLightBetrays condTgtEnemyPresent condNotCalmEnough b activeItems itemFull , permitted (fst <$> benefit) itemFull b activeItems && (cstore /= CEqp || hind) ] benCStore cs = do bag <- getsState $ getActorBag aid cs return $! ben cs bag perBag <- mapM benCStore cstores return $ concat perBag -- keep it lazy -- TODO: also take into account dynamic lights *not* wielded by the actor hinders :: Bool -> Bool -> Bool -> Bool -> Actor -> [ItemFull] -> ItemFull -> Bool hinders condAnyFoeAdj condLightBetrays condTgtEnemyPresent condNotCalmEnough -- perhaps enemies don't have projectiles body activeItems itemFull = let itemLit = isJust $ strengthFromEqpSlot IK.EqpSlotAddLight itemFull itemLitBad = itemLit && condNotCalmEnough && not condAnyFoeAdj in -- 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 && (itemLitBad || 0 > fromMaybe 0 (strengthFromEqpSlot IK.EqpSlotAddHurtMelee itemFull)) -- In the presence of enemies (seen, or unseen but distressing) -- actors want to hide in the dark. || let heavilyDistressed = -- actor hit by a proj or similarly distressed deltaSerious (bcalmDelta body) in itemLitBad && condLightBetrays && (heavilyDistressed || condTgtEnemyPresent) -- 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) -- | 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 -- that are worth picking up. benGroundItems :: MonadClient m => ActorId -> m [( (Maybe (Int, Int) , (Int, CStore)), (ItemId, ItemFull) )] benGroundItems aid = do b <- getsState $ getActorBody aid canEscape <- factionCanEscape (bfid b) benAvailableItems aid (\use itemFull _ _ -> desirableItem canEscape use itemFull) [CGround] desirableItem :: Bool -> Maybe Int -> ItemFull -> Bool desirableItem canEsc use itemFull = let item = itemBase itemFull freq = case itemDisco itemFull of Nothing -> [] Just ItemDisco{itemKind} -> IK.ifreq itemKind in if canEsc then use /= Just 0 || IK.Precious `elem` jfeature item else -- A hack to prevent monsters from picking up unidentified treasure. let preciousWithoutSlot = IK.Precious `elem` jfeature item -- risk from treasure hunters && isNothing (strengthEqpSlot item) -- unlikely to be useful in use /= Just 0 && not (isNothing use -- needs resources to id && preciousWithoutSlot) -- TODO: terrible hack for the identified healing gems and normal -- gems identified with a scroll && maybe True (<= 0) (lookup "gem" freq) -- | Require the actor is in a bad position to melee or can't melee at all. condMeleeBadM :: MonadClient m => ActorId -> m Bool condMeleeBadM aid = do b <- getsState $ getActorBody aid btarget <- getsClient $ getTarget aid mtgtPos <- aidTgtToPos aid (blid b) btarget condTgtEnemyPresent <- condTgtEnemyPresentM aid condTgtEnemyRemembered <- condTgtEnemyRememberedM aid fact <- getsState $ (EM.! bfid b) . sfactionD activeItems <- activeItemsClient aid let condNoUsableWeapon = all (not . isMelee) activeItems 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 > 0 && (dist <= 2 || approaching b2) -- 3 is the condThreatAtHand distance that AI keeps when alone. approaching = case mtgtPos of Just tgtPos | condTgtEnemyPresent || condTgtEnemyRemembered -> \b1 -> chessDist (bpos b1) tgtPos <= 3 _ -> const False closeFriends = filter (closeEnough . snd) friends strongActor (aid2, b2) = do activeItems2 <- activeItemsClient aid2 let condUsableWeapon2 = any isMelee activeItems2 actorMaxSk2 = sumSkills activeItems2 canMelee2 = EM.findWithDefault 0 Ability.AbMelee actorMaxSk2 > 0 hpGood = not $ hpTooLow b2 activeItems2 return $! hpGood && condUsableWeapon2 && canMelee2 strongCloseFriends <- filterM strongActor closeFriends let noFriendlyHelp = length closeFriends < 3 && null strongCloseFriends && length friends > 1 -- solo fighters aggresive && not (hpHuge b) -- uniques, etc., aggresive let actorMaxSk = sumSkills activeItems return $ condNoUsableWeapon || EM.findWithDefault 0 Ability.AbMelee actorMaxSk <= 0 || 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 IK.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 => ActorId -> m ([(Int, Point)], [(Int, Point)]) fleeList aid = do cops <- getsState scops mtgtMPath <- getsClient $ EM.lookup aid . stargetD let tgtPath = case mtgtMPath of -- prefer fleeing along the path to target Just (TEnemy{}, _) -> [] -- don't flee towards an enemy Just (TEnemyPos{}, _) -> [] 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 eqVic = filter ((== dist (bpos b)) . fst) accVic ltVic = filter ((< dist (bpos b)) . fst) accVic rewardPath mult (d, p) | p `elem` tgtPath = (100 * mult * d, p) | any (\q -> chessDist p q == 1) tgtPath = (10 * mult * d, p) | otherwise = (mult * d, p) goodVic = map (rewardPath 10000) gtVic ++ map (rewardPath 100) eqVic badVic = map (rewardPath 1) ltVic return (goodVic, badVic) -- keep it lazy LambdaHack-0.5.0.0/Game/LambdaHack/Client/AI/Strategy.hs0000644000000000000000000000723212555256425020513 0ustar0000000000000000{-# LANGUAGE DeriveFoldable, DeriveTraversable, 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.Foldable (Foldable) import Data.Maybe import Data.Text (Text) import Data.Traversable (Traversable) 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, Foldable, Traversable) -- | 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] -- TODO: express with traverse? 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 LambdaHack-0.5.0.0/Game/LambdaHack/Client/AI/Preferences.hs0000644000000000000000000001735712555256425021163 0ustar0000000000000000-- | Actor preferences for targets and actions based on actor attributes. module Game.LambdaHack.Client.AI.Preferences ( totalUsefulness, effectToBenefit ) where import Control.Applicative import qualified Data.EnumMap.Strict as EM import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState import qualified Game.LambdaHack.Common.Dice as Dice 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 (ItemKind) import qualified Game.LambdaHack.Content.ItemKind as IK import Game.LambdaHack.Content.ModeKind -- | 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 -> IK.Effect -> Int effectToBenefit cops b activeItems fact eff = let dungeonDweller = not $ fcanEscape $ gplayer fact in case eff of IK.NoEffect _ -> 0 IK.Hurt d -> -(min 150 $ 10 * Dice.meanDice d) IK.Burn d -> -(min 200 $ 15 * Dice.meanDice d) -- often splash damage, etc. IK.Explode _ -> 0 -- depends on explosion IK.RefillHP p -> let hpMax = sumSlotNoFilter IK.EqpSlotAddMaxHP activeItems in if p > 0 -- TODO: when picking up, always deem valuable; when drinking, only if -- HP not maxxed. then 10 * min p (max 0 $ fromIntegral $ (xM hpMax - bhp b) `divUp` oneM) else max (-99) (11 * p) IK.OverfillHP p -> let hpMax = sumSlotNoFilter IK.EqpSlotAddMaxHP activeItems in if p > 0 then 11 * min p (max 1 $ fromIntegral $ (xM hpMax - bhp b) `divUp` oneM) else max (-99) (11 * p) IK.RefillCalm p -> let calmMax = sumSlotNoFilter IK.EqpSlotAddMaxCalm activeItems in if p > 0 then min p (max 0 $ fromIntegral $ (xM calmMax - bcalm b) `divUp` oneM) else max (-20) p IK.OverfillCalm p -> let calmMax = sumSlotNoFilter IK.EqpSlotAddMaxCalm activeItems in if p > 0 then min p (max 1 $ fromIntegral $ (xM calmMax - bcalm b) `divUp` oneM) else max (-20) p IK.Dominate -> -200 IK.Impress -> -10 IK.CallFriend d -> 100 * Dice.meanDice d IK.Summon _ d | dungeonDweller -> -- Probably summons friends or crazies. -- TODO: should be Negative, to use Calm of enemy, but also positive -- to use with own Calm, if needed. 50 * Dice.meanDice d IK.Summon{} -> 0 -- probably generates enemies IK.Ascend{} -> 1 -- low, to only change levels sensibly, in teams -- TODO: use if low HP and enemies at hand IK.Escape{} -> 10000 -- AI wants to win; spawners to guard IK.Paralyze d -> -20 * Dice.meanDice d IK.InsertMove d -> 50 * Dice.meanDice d IK.Teleport d -> let p = Dice.meanDice d in if p <= 8 -- blink to shoot at foe && dungeonDweller -- non-dwellers have to explore and escape ASAP then 1 else -p -- get rid of the foe IK.CreateItem COrgan grp _ -> -- TODO: use the timeout let (total, count) = organBenefit grp cops b activeItems fact in total `divUp` count -- average over all matching grp; rarities ignored IK.CreateItem{} -> 30 -- TODO IK.DropItem COrgan grp True -> -- calculated for future use, general pickup let (total, _) = organBenefit grp cops b activeItems fact in - total -- sum over all matching grp; simplification: rarities ignored IK.DropItem _ _ False -> -15 IK.DropItem _ _ True -> -30 IK.PolyItem -> 0 -- AI can't estimate item desirability vs average IK.Identify -> 0 -- AI doesn't know how to use IK.SendFlying _ -> -10 -- but useful on self sometimes, too IK.PushActor _ -> -10 -- but useful on self sometimes, too IK.PullActor _ -> -10 IK.DropBestWeapon -> -50 IK.ActivateInv ' ' -> -100 IK.ActivateInv _ -> -50 IK.ApplyPerfume -> 0 -- depends on the smell sense of friends and foes IK.OneOf _ -> 1 -- usually a mixed blessing, but slightly beneficial IK.OnSmash _ -> 0 -- TOOD: can be beneficial or not; analyze explosions IK.Recharging e -> -- Used, e.g., in @periodicBens@, which takes timeout into account, too. effectToBenefit cops b activeItems fact e IK.Temporary _ -> 0 -- TODO: calculating this for "temporary conditions" takes forever organBenefit :: GroupName ItemKind -> Kind.COps -> Actor -> [ItemFull] -> Faction -> (Int, Int) organBenefit t cops@Kind.COps{coitem=Kind.Ops{ofoldrGroup}} b activeItems fact = let f p _ kind (sacc, pacc) = let paspect asp = p * aspectToBenefit cops b (Dice.meanDice <$> asp) peffect eff = p * effectToBenefit cops b activeItems fact eff in ( sacc + sum (map paspect $ IK.iaspects kind) + sum (map peffect $ IK.ieffects kind) , pacc + p ) in ofoldrGroup t f (0, 0) -- | Return the value to add to effect value. aspectToBenefit :: Kind.COps -> Actor -> IK.Aspect Int -> Int aspectToBenefit _cops _b asp = case asp of IK.Unique{} -> 0 IK.Periodic{} -> 0 IK.Timeout{} -> 0 IK.AddHurtMelee p -> p IK.AddHurtRanged p | p < 0 -> 0 -- TODO: don't ignore for missiles IK.AddHurtRanged p -> p `divUp` 5 -- TODO: should be summed with damage IK.AddArmorMelee p -> p `divUp` 5 IK.AddArmorRanged p -> p `divUp` 10 IK.AddMaxHP p -> p IK.AddMaxCalm p -> p `div` 5 IK.AddSpeed p -> p * 10000 IK.AddSkills m -> 5 * sum (EM.elems m) IK.AddSight p -> p * 10 IK.AddSmell p -> p * 10 IK.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) 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 = map (effectToBenefit cops b activeItems fact) (allRecharging effects) periodicBens = case strengthFromEqpSlot IK.EqpSlotPeriodic itemFull of Nothing -> [] Just timeout -> map (\eff -> eff * 10 `divUp` timeout) periodicEffBens selfBens = aspBens ++ periodicBens selfSum = sum selfBens mixedBlessing = not (null selfBens) && (selfSum > 0 && minimum selfBens < -10 || selfSum < 0 && maximum selfBens > 10) effSum = sum effBens isWeapon = isMeleeEqp itemFull totalSum | isWeapon && effSum < 0 = - effSum + selfSum | not $ goesIntoEqp itemFull = effSum | mixedBlessing = 0 -- significant mixed blessings out of AI control | otherwise = selfSum -- if the weapon heals the enemy, it -- won't be used but can be equipped in (totalSum, effSum) in case itemDisco itemFull of Just ItemDisco{itemAE=Just ItemAspectEffect{jaspects, jeffects}} -> Just $ ben jeffects jaspects Just ItemDisco{itemKind=IK.ItemKind{iaspects, ieffects}} -> let jaspects = map (fmap Dice.meanDice) iaspects in Just $ ben ieffects jaspects _ -> Nothing LambdaHack-0.5.0.0/Game/LambdaHack/Client/AI/PickTargetClient.hs0000644000000000000000000004441112555256425022105 0ustar0000000000000000{-# LANGUAGE TupleSections #-} -- | Let AI pick the best target for an actor. module Game.LambdaHack.Client.AI.PickTargetClient ( targetStrategy, createPath ) 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 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 Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.Frequency 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.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 qualified Game.LambdaHack.Content.ItemKind as IK import Game.LambdaHack.Content.ModeKind import Game.LambdaHack.Content.RuleKind -- | AI proposes possible targets for the actor. Never empty. targetStrategy :: forall m. MonadClient m => ActorId -> m (Strategy (Target, Maybe PathEtc)) targetStrategy aid = do cops@Kind.COps{corule, cotile=cotile@Kind.Ops{ouniqGroup}} <- getsState scops let stdRuleset = Kind.stdRuleset corule nearby = rnearby stdRuleset itemToF <- itemToFullClient modifyClient $ \cli -> cli { sbfsD = invalidateBfs 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 mtgtMPath <- getsClient $ EM.lookup aid . stargetD oldTgtUpdatedPath <- case mtgtMPath of Just (tgt, Nothing) -> -- This case is especially for TEnemyPos that would be lost otherwise. -- This is also triggered by @UpdLeadFaction@. The recreated path can be -- different than on the other client (AI or UI), but we don't care -- as long as the target stays the same at least for a moment. createPath aid tgt 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 let !_A = assert (p == goal `blame` (aid, b, mtgtMPath)) () 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) Nothing -> return Nothing -- no target assigned yet let !_A = assert (not $ bproj b) () -- would work, but is probably a bug fact <- getsState $ (EM.! bfid b) . sfactionD allFoes <- getsState $ actorRegularAssocs (isAtWar fact) (blid b) dungeon <- getsState sdungeon -- We assume the actor eventually becomes a leader (or has the same -- set of abilities as the leader, anyway) and set his target accordingly. let actorMaxSk = sumSkills activeItems actorMinSk <- getsState $ actorSkills Nothing aid activeItems condCanProject <- condCanProjectM True aid condHpTooLow <- condHpTooLowM aid condEnoughGear <- condEnoughGearM aid condMeleeBad <- condMeleeBadM 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) canEscape <- factionCanEscape (bfid b) explored <- getsClient sexplored smellRadius <- sumOrganEqpClient IK.EqpSlotAddSmell aid let condNoUsableWeapon = all (not . isMelee) activeItems lidExplored = ES.member (blid b) explored allExplored = ES.size explored == EM.size dungeon canSmell = smellRadius > 0 meleeNearby | canEscape = nearby `div` 2 -- not aggresive | otherwise = nearby rangedNearby = 2 * meleeNearby -- Don't target nonmoving actors at all if bad melee, -- because nonmoving can't be lured nor ambushed. -- This is especially important for fences, tower defense actors, etc. -- If content gives nonmoving actor loot, this becomes problematic. targetableMelee aidE body = do activeItemsE <- activeItemsClient aidE let actorMaxSkE = sumSkills activeItemsE attacksFriends = any (adjacent (bpos body) . bpos) friends n = if attacksFriends then rangedNearby else meleeNearby nonmoving = EM.findWithDefault 0 AbMove actorMaxSkE <= 0 return {-keep lazy-} $ chessDist (bpos body) (bpos b) < n && not condNoUsableWeapon && EM.findWithDefault 0 AbMelee actorMaxSk > 0 && not (hpTooLow b activeItems) && not (nonmoving && condMeleeBad) targetableRangedOrSpecial body = chessDist (bpos body) (bpos b) < rangedNearby && condCanProject targetableEnemy (aidE, body) = do tMelee <- targetableMelee aidE body return $! targetableRangedOrSpecial body || tMelee nearbyFoes <- filterM targetableEnemy allFoes let unknownId = ouniqGroup "unknown space" itemUsefulness itemFull = fst <$> totalUsefulness cops b activeItems fact itemFull desirableBag bag = any (\(iid, k) -> let itemFull = itemToF iid k use = itemUsefulness itemFull in desirableItem canEscape use itemFull) $ 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 couldMoveLastTurn = let axtorSk = if (fst <$> gleader fact) == Just aid then actorMaxSk else actorMinSk in EM.findWithDefault 0 AbMove axtorSk > 0 isStuck = waitedLastTurn b && couldMoveLastTurn slackTactic = ftactic (gplayer fact) `elem` [TMeleeAndRanged, TMeleeAdjacent, TBlock, TRoam, TPatrol] setPath :: Target -> m (Strategy (Target, Maybe PathEtc)) setPath tgt = do mpath <- createPath aid tgt let take5 (TEnemy{}, pgl) = (tgt, Just pgl) -- for projecting, even by roaming actors take5 (_, pgl@(path, (goal, _))) = if slackTactic then -- Best path only followed 5 moves; then straight on. let path5 = take 5 path vtgt | bpos b == goal = tgt | otherwise = TVector $ towards (bpos b) goal in (vtgt, Just (path5, (last path5, length path5 - 1))) else (tgt, Just pgl) return $! returN "setPath" $ maybe (tgt, Nothing) take5 mpath pickNewTarget :: m (Strategy (Target, Maybe PathEtc)) pickNewTarget = do -- This is mostly lazy and used between 0 and 3 times below. ctriggers <- closestTriggers Nothing aid -- 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 let ctriggersEarly = if EM.findWithDefault 0 AbTrigger actorMaxSk > 0 && condEnoughGear then ctriggers else mzero if nullFreq ctriggersEarly then do citems <- if EM.findWithDefault 0 AbMoveItem actorMaxSk > 0 then closestItems aid else return [] case filter desirable citems of [] -> do let vToTgt v0 = do let vFreq = toFreq "vFreq" $ (20, v0) : map (1,) moves v <- rndToAction $ frequency vFreq -- Items and smells, etc. considered every 7 moves. let tra = trajectoryToPathBounded lxsize lysize (bpos b) (replicate 7 v) path = nub $ bpos b : tra return $! returN "tgt with no exploration" ( TVector v , if length path == 1 then Nothing else Just (path, (last path, length path - 1)) ) oldpos = fromMaybe (Point 0 0) (boldpos b) vOld = bpos b `vectorToFrom` oldpos pNew = shiftBounded lxsize lysize (bpos b) vOld if slackTactic && not isStuck && isUnit vOld && bpos b /= pNew && accessible cops lvl (bpos b) pNew then vToTgt vOld else do 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 let ctriggersMiddle = if EM.findWithDefault 0 AbTrigger actorMaxSk > 0 && not allExplored then ctriggers else mzero if nullFreq ctriggersMiddle then do -- All stones turned, time to win or die. afoes <- closestFoes allFoes aid case afoes of (_, (aid2, _)) : _ -> setPath $ TEnemy aid2 False [] -> if nullFreq ctriggers then do furthest <- furthestKnown aid setPath $ TPoint (blid b) furthest else do p <- rndToAction $ frequency ctriggers setPath $ TPoint (blid b) p else do p <- rndToAction $ frequency ctriggers setPath $ TPoint (blid b) p p : _ -> setPath $ TPoint (blid b) p Just p -> setPath $ TPoint (blid b) p (_, (p, _)) : _ -> setPath $ TPoint (blid b) p else do p <- rndToAction $ frequency ctriggers 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 permit -> 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 || permit -- never follow a friend more than 1 step 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 permit -- Chase last position even if foe hides or dies, -- to find his companions, loot, etc. | lid /= blid b -- wrong level || chessDist (bpos b) p >= nearby -- too far and not visible || permit -- never follow a friend more than 1 step -> pickNewTarget | p == bpos b -> tellOthersNothingHere p | otherwise -> return $! returN "TEnemyPos" (oldTgt, Just updatedPath) _ | not $ null nearbyFoes -> pickNewTarget -- prefer close foes to anything TPoint lid pos -> do bag <- getsState $ getCBag $ CFloor lid pos let t = lvl `at` pos 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 actorMaxSk <= 0 || not (desirableBag bag)) -- closestItems && (pos == bpos b || (not canSmell -- closestSmell || let sml = EM.findWithDefault timeZero pos (lsmell lvl) in sml <= ltime lvl) && if not lidExplored then t /= unknownId -- closestUnknown && not (Tile.isSuspect cotile t) -- closestSuspect && not (condEnoughGear && Tile.isStair cotile t) else -- closestTriggers -- Try to kill that very last enemy for his loot before -- leaving the level or dungeon. not (null allFoes) || -- If all explored, escape/block escapes. (not (Tile.isEscape cotile t) || not 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, unless he can't -- trigger them at all. && (EM.findWithDefault 0 AbTrigger actorMaxSk <= 0 || not (Tile.isStair cotile t)) -- The remaining case is furthestKnown. This is -- always an unimportant target, so we forget it -- if the actor is stuck (waits, though could move; -- or has zeroed individual moving skill, -- but then should change targets often anyway). && (isStuck || not 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 createPath :: MonadClient m => ActorId -> Target -> m (Maybe (Target, PathEtc)) createPath aid tgt = do b <- getsState $ getActorBody aid mpos <- aidTgtToPos aid (blid b) (Just tgt) case mpos of Nothing -> return Nothing -- TODO: for now, an extra turn at target is needed, e.g., to pick up items -- Just p | p == bpos b -> 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) )) LambdaHack-0.5.0.0/GameDefinition/0000755000000000000000000000000012555256425014704 5ustar0000000000000000LambdaHack-0.5.0.0/GameDefinition/MainMenu.ascii0000644000000000000000000000415612555256425017435 0ustar0000000000000000---------------------------------------------------------------------------------- | | | >> LambdaHack << | | | | | | {{{{{{{{{{{{{{{{{{{{{{{{{ | | | | {{{{{{{{{{{{{{{{{{{{{{{{{ | | | | {{{{{{{{{{{{{{{{{{{{{{{{{ | | | | {{{{{{{{{{{{{{{{{{{{{{{{{ | | | | {{{{{{{{{{{{{{{{{{{{{{{{{ | | | | {{{{{{{{{{{{{{{{{{{{{{{{{ | | | | {{{{{{{{{{{{{{{{{{{{{{{{{ | | | | {{{{{{{{{{{{{{{{{{{{{{{{{ | | | | {{{{{{{{{{{{{{{{{{{{{{{{{ | | | | | | Version X.X.X (frontend: gtk, engine: LambdaHack X.X.X) | ---------------------------------------------------------------------------------- LambdaHack-0.5.0.0/GameDefinition/Main.hs0000644000000000000000000000057712555256425016135 0ustar0000000000000000-- | The main source code file of LambdaHack the game. -- Module "TieKnot" is separated to make it usable in tests. module Main ( main ) where import System.Environment (getArgs) import TieKnot -- | Tie the LambdaHack engine client, server and frontend code -- with the game-specific content definitions, and run the game. main :: IO () main = do args <- getArgs tieKnot args LambdaHack-0.5.0.0/GameDefinition/scores0000644000000000000000000000160712555256425016131 0ustar0000000000000000xœ•V]HQ¾ó³ì®¤ì“OÚ[O!h «DmØ®š¸c.ëOì’F®ä[HÑCAD„Y$’eA–Zi©•Y Bö‡Ia„¤m™ÙÌî|wLJÜûrÏÞ½sÎ÷}÷žs.!±a"òàâ“íä²8F‹?;ˆ§ëÂ8ÃÈHĽ³•_–¾Âçës½uBM(Ž½eÐayí†q[6àÐþžûà«{`<†ñD6Œƒ²ÁÁßS#Øü+ã0^¯ n+•8´vçÏÁŽöÉȦį!iøI¦GÅm#¸m7+¸YÁÍü¤ $ iIHZŸae~@Û6*–çðüB6ìPÄ8†¿4Ò¬‹O\ŒùTSÙ;âÉr'¤É9u?35iièù3ºço„FFhÄA#* i8HÃ@Žž?øSÚhs”6¢³òïT‰Ìâä±6ñ"\îJ°}0ãnœÛ?j¶ëŠ+}!ÁQ(”‡A_@V3`3€@‹óc’Õ? ©—@ü—@vRIÔ¼o‚$ ’¹¥ònÔ$YBd Mä™Åæø”žñwžOûø…’yÎEœ r Q7ìqùeA¿PUßwT9ŠYï:Y;%÷¿šòIJåœISdt^ÓØMxh´jxŒDTL ì¦äu¡÷ !îö†=Š¨G›¯ûIRQÙ³0Ϋ‚Ð˜s08@ŒOé®Ø5”ÄÛ¬À1û1# ìâÛö‹ákëÞ€/¨"ÏÜ“ >>Y¯J.~vNED¿´(B”ºs5!@5™ä•äb®7*Þsçì5EˆÊ‰i’LkºÀbE¾¿é[c'£_¬wι>EÐïºÒ¥åª¯C¯!Ü…Œ(v)š†`Ñ;yÈ#-šfg@f´™)ÏþXB¶•Š=Îùc^Q5J¾ÉÖUsÄ°1;ˆ¥€bœåù½ùûÂ61W+§O+žÇ¿F#@¶ A¶»¶&¹kÃâI‡®Š _9Ê 6¡¯ø·Ð|¦i M˜…À<ú+-}FLßÈÂê˜Ò—ȧ «^ÁÇsàSn}^#3øèó[hwD†¾|Ì+÷Z/J¢¶ñ2äoRÜòíE Yºå‘ßQ¦}CÝÀW)ÊêwÐ%¨9-›—2uË#W(x×Cƒ‹uíúÐõ ¦LambdaHack-0.5.0.0/GameDefinition/PLAYING.md0000644000000000000000000002601712555256425016337 0ustar0000000000000000Playing 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. 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 set of scenarios, even though they are playable and winnable. Contributions are welcome. Heroes ------ The heroes are marked on the map with symbols `@` and `1` through `9`. Their goal is to explore the dungeon, battle the horrors within, gather as much gold and gems as possible, and escape to tell the tale. The 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 [**__] The line starts with the list of party members (unless there's only one member) and the shortened name of the team. Clicking on the list selects heroes and the selected run together when `:` or `SHIFT`-left mouse button is pressed. Then comes the damage of the highest damage dice weapon the leader can use, 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. Weapon damage and other item stats are displayed using the dice notation `XdY`, which means X rolls of Y-sided dice. A variant denoted `XdsY` is additionally scaled by the level depth in proportion to the maximal dungeon depth. You can read more about combat resolution in section Monsters below. The second status line describes the current level in relation to the party. 5 Lofty hall [33% seen] X-hair: exact spot (71,12) p15 l10 First comes the depth of the current level and its name. Then the percentage of its explorable tiles already seen by the heroes. The 'X-hair' (meaning 'crosshair') is the common focus of the whole party, denoted on the map by a white box and manipulated with movement keys in aiming mode. At the end of the status line comes the length of the shortest path from the leader to the crosshair position and the straight-line distance between the two points. Dungeon ------- The dungeon of any particular scenario may consist of one or many levels and each level consists of a large number of tiles. The basic tile kinds are as follows. 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 The game world is persistent, i.e., every time the player visits a level during a single game, its layout is the same. Commands -------- You walk throughout a level using the left mouse button or the numeric 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). 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 aiming mode (`KEYPAD_*` or `\`) the same keys (or the middle and right mouse buttons) move the crosshair (the white box). In normal mode, `SHIFT` (or `CTRL`) and a movement key make the current party leader run in the indicated direction, until anything of interest is spotted. The `5` keypad key and the `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`). 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 the more general commands or as building blocks for more complex convenience macros. E.g., the autoexplore command (key `X`) could be defined by the player as a macro using `CTRL-?`, `CTRL-.` and `V`. The following minimal command set lets you accomplish almost anything in the game, though not necessarily with the fewest number of keystrokes. The full list of commands can be seen in the in-game help accessible from the Main Menu. keys command < ascend a level > descend a level c close door E manage equipment of the leader g or , get items a apply consumable f fling projectile + swerve the aiming line D display player diary T toggle suspect terrain display SHIFT-TAB cycle among all party members ESC cancel action, open Main Menu The only activity not possible with the commands above is the management of non-leader party members. You don't need it, unless your non-leader actors can move or fire opportunistically (via innate skills or rare equipment). If really needed, you can manually set party tactics with `CTRL-T` and you can assign individual targets to party members using the aiming and targeting commands listed below. keys command KEYPAD_* or \ aim at an enemy KEYPAD_/ or | cycle aiming styles + swerve the aiming line - unswerve the aiming line CTRL-? set crosshair to the closest unknown spot CTRL-I set crosshair to the closest item CTRL-{ set crosshair to the closest stairs up CTRL-} set crosshair to the closest stairs down BACKSPACE reset target/crosshair RET or INSERT accept target/choice For ranged attacks, setting the crosshair or individual targets beforehand is not mandatory, because the crosshair is set automatically as soon as a monster comes into view and can still be adjusted while in the missile choice menu. However, if you want to assign persistent personal targets or just inspect the level map closely, you can enter the detailed aiming mode with the right mouse button or with the `*` keypad key that selects enemies or the `/` keypad key that marks a tile. You can move the aiming crosshair with direction keys and assign a personal target to the leader with `RET`. The details of the shared crosshair position and of the personal target are described in the status lines at the bottom of the screen. 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 Raid scenario offers a gentle introduction. The subsequent game modes gradually introduce squad combat, stealth, opportunity fire, asymmetric battles and more. Monsters -------- Heroes are not alone in the dungeon. Monstrosities, natural and out of this world, roam the dark caves and crawl from damp holes day and night. While heroes pay attention to all other party members and take care to move one at a time, monsters don't care about each other and all move at once, sometimes brutally colliding by accident. When the hero bumps into a monster or a monster attacks the hero, melee combat occurs. 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. In some circumstances actors are immune to the displacing, e.g., when both parties form a continuous front-line. In melee combat, the best equipped weapon (or the best fighting organ) of each opponent is taken into account for determining the damage and any extra effects of the blow. If a recharged weapon with a non-trivial effect is in the equipment, it is preferred for combat. Otherwise combat involves the weapon with the highest raw damage dice (the same as displayed at bottommost status line). To determine the damage dealt, the outcome of the weapon's damage dice roll is multiplied by the melee damage bonus (summed from the equipped items of the attacker) minus the melee armor modifier of the defender. Regardless of the calculation, each attack inflicts at least 1 damage. The current leader's melee bonus, armor modifier and other detailed stats can be viewed via the `!` command. In ranged combat, the missile is assumed to be attacking the defender in melee, using itself as the weapon, but the ranged damage bonus and the ranged armor modifier are taken into account for calculations. You may propel any item in your equipment, inventory pack and on the ground (by default you are offered only the appropriate items; press `?` to cycle item menu modes). Only items of a few kinds inflict any damage, but some have other effects, beneficial, detrimental or mixed. Whenever the monster's or hero's hit points reach zero, the combatant dies. When the last hero dies, the scenario ends in defeat. On Winning and Dying -------------------- You win the scenario if you escape the dungeon alive or, in scenarios with no exit locations, if you eliminate all opposition. In the former case, your score is based on the gold and precious gems you've plundered. In the latter case, your score is based on the number of turns you spent overcoming your foes (the quicker the victory, the better; the slower the demise, the better). Bonus points, based on the number of heroes lost, are awarded if you win. When all your heroes fall, you are going to invariably see a new foolhardy party of adventurers clamoring to be led into the dungeon. They start their conquest from a new entrance, with no experience and no equipment, and new, undaunted enemies bar their way. Lead the new hopeful explorers with wisdom and fortitude! LambdaHack-0.5.0.0/GameDefinition/TieKnot.hs0000644000000000000000000000440412555256425016617 0ustar0000000000000000-- | 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.ItemKind import qualified Content.ModeKind import qualified Content.PlaceKind import qualified Content.RuleKind import qualified Content.TileKind import Game.LambdaHack.Client import qualified Game.LambdaHack.Common.Kind as Kind import Game.LambdaHack.SampleImplementation.SampleMonadClient (executorCli) import Game.LambdaHack.SampleImplementation.SampleMonadServer (executorSer) import Game.LambdaHack.Server -- | Tie the LambdaHack engine client, server and frontend code -- with the game-specific content definitions, and run the game. tieKnot :: [String] -> IO () tieKnot args = do let -- Common content operations, created from content definitions. -- Evaluated fully to discover errors ASAP and free memory. !copsSlow = Kind.COps { cocave = Kind.createOps Content.CaveKind.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 } !copsShared = speedupCOps False copsSlow -- Client content operations. copsClient = Content.KeyKind.standardKeys sdebugNxt <- debugArgs args -- 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. let exeServer executorUI executorAI = executorSer $ loopSer copsShared sdebugNxt executorUI executorAI -- Currently a single frontend is started by the server, -- instead of each client starting it's own. srtFrontend (executorCli . loopUI) (executorCli . loopAI) copsClient copsShared (sdebugCli sdebugNxt) exeServer LambdaHack-0.5.0.0/GameDefinition/config.ui.default0000644000000000000000000000307412555256425020137 0ustar0000000000000000; 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\\AppData\Roaming\LambdaHack\config.ui.ini ; or elsewhere. [extra_commands] ; A handy shorthand with Vi keys Macro_1 = ("comma", ([CmdItem], Macro "" ["g"])) ; Angband compatibility (accept target) Macro_2 = ("KP_Insert", ([CmdMeta], Macro "" ["Return"])) [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") [ui] movementViKeys_hjklyubn = False movementLaptopKeys_uk8o79jl = True ; Monospace fonts that have fixed size regardless of boldness (on some OSes) font = "Terminus,DejaVu Sans Mono,Consolas,Courier New,Liberation Mono,Courier,FreeMono,Monospace normal normal normal normal 14" ;font = "Terminus,DejaVu Sans Mono,Consolas,Courier New,Liberation Mono,Courier,FreeMono,Monospace normal normal normal normal 18" colorIsBold = True ; New historyMax takes effect after removal of savefiles. historyMax = 5000 maxFps = 30 noAnim = False runStopMsgs = False LambdaHack-0.5.0.0/GameDefinition/Content/0000755000000000000000000000000012555256425016316 5ustar0000000000000000LambdaHack-0.5.0.0/GameDefinition/Content/ItemKindBlast.hs0000644000000000000000000003430412555256425021350 0ustar0000000000000000-- | Blast definitions. module Content.ItemKindBlast ( blasts ) where import Game.LambdaHack.Common.Color import Game.LambdaHack.Common.Dice import Game.LambdaHack.Common.Flavour import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.Msg import Game.LambdaHack.Content.ItemKind blasts :: [ItemKind] blasts = [burningOil2, burningOil3, burningOil4, explosionBlast2, explosionBlast10, explosionBlast20, firecracker2, firecracker3, firecracker4, firecracker5, firecracker6, firecracker7, fragrance, pheromone, mistCalming, odorDistressing, mistHealing, mistHealing2, mistWounding, distortion, waste, glassPiece, smoke, boilingWater, glue, spark, mistAntiSlow, mistAntidote, mistStrength, mistWeakness, protectingBalm, vulnerabilityBalm, hasteSpray, slownessSpray, eyeDrop, smellyDroplet, whiskeySpray] burningOil2, burningOil3, burningOil4, explosionBlast2, explosionBlast10, explosionBlast20, firecracker2, firecracker3, firecracker4, firecracker5, firecracker6, firecracker7, fragrance, pheromone, mistCalming, odorDistressing, mistHealing, mistHealing2, mistWounding, distortion, waste, glassPiece, smoke, boilingWater, glue, spark, mistAntiSlow, mistAntidote, mistStrength, mistWeakness, protectingBalm, vulnerabilityBalm, hasteSpray, slownessSpray, eyeDrop, smellyDroplet, whiskeySpray :: ItemKind -- * Parameterized immediate effect blasts burningOil :: Int -> ItemKind burningOil n = ItemKind { isymbol = '*' , iname = "burning oil" , ifreq = [(toGroupName $ "burning oil" <+> tshow n, 1)] , iflavour = zipFancy [BrYellow] , icount = intToDice (n * 5) , irarity = [(1, 1)] , iverbHit = "burn" , iweight = 1 , iaspects = [AddLight 2] , ieffects = [Burn 1, Paralyze 1] -- 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 = "blast" , ifreq = [(toGroupName $ "blast" <+> tshow n, 1)] , iflavour = zipPlain [BrRed] , icount = 15 -- 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)] ++ [PushActor (ThrowMod (100 * (n `div` 5)) 50)] ++ [DropItem COrgan "temporary conditions" True | n >= 10] , ifeature = [Fragile, toLinger 20, Identified] , idesc = "" , ikit = [] } explosionBlast2 = explosionBlast 2 explosionBlast10 = explosionBlast 10 explosionBlast20 = explosionBlast 20 firecracker :: Int -> ItemKind firecracker n = ItemKind { isymbol = '*' , iname = "firecracker" , ifreq = [(toGroupName $ "firecracker" <+> tshow n, 1)] , iflavour = zipPlain [brightCol !! (n `mod` length brightCol)] , icount = intToDice (n `div` 6) + d (n `div` 2) , irarity = [(1, 1)] , iverbHit = "crack" , iweight = 1 , iaspects = [AddLight $ intToDice $ n `div` 2] , ieffects = [ RefillCalm (-1) | n >= 5 ] ++ [ DropBestWeapon | n >= 5] ++ [ OnSmash (Explode $ toGroupName $ "firecracker" <+> tshow (n - 1)) | n > 2 ] , ifeature = [ ToThrow $ ThrowMod (10 + 3 * n) (10 + 100 `div` n) , Fragile, Identified ] , idesc = "" , ikit = [] } firecracker7 = firecracker 7 firecracker6 = firecracker 6 firecracker5 = firecracker 5 firecracker4 = firecracker 4 firecracker3 = firecracker 3 firecracker2 = firecracker 2 -- * Assorted immediate effect blasts fragrance = ItemKind { isymbol = '\'' , iname = "fragrance" , ifreq = [("fragrance", 1)] , iflavour = zipFancy [Magenta] , icount = 20 , irarity = [(1, 1)] , iverbHit = "engulf" , iweight = 1 , iaspects = [] , ieffects = [Impress] -- Linger 10, because sometimes it takes 2 turns due to starting just -- before actor turn's end (e.g., via a necklace). , ifeature = [ ToThrow $ ThrowMod 28 10 -- 2 steps, one turn , Fragile, Identified ] , idesc = "" , ikit = [] } pheromone = ItemKind { isymbol = '\'' , iname = "musky whiff" , ifreq = [("pheromone", 1)] , iflavour = zipFancy [BrMagenta] , icount = 18 , irarity = [(1, 1)] , iverbHit = "tempt" , iweight = 1 , iaspects = [] , ieffects = [Impress, OverfillCalm (-20)] , ifeature = [ toVelocity 13 -- the slowest that travels at least 2 steps , Fragile, Identified ] , idesc = "" , ikit = [] } mistCalming = ItemKind { isymbol = '\'' , iname = "mist" , ifreq = [("calming mist", 1)] , iflavour = zipFancy [White] , icount = 19 , irarity = [(1, 1)] , iverbHit = "sooth" , iweight = 1 , iaspects = [] , ieffects = [RefillCalm 2] , ifeature = [ toVelocity 13 -- the slowest that travels at least 2 steps , Fragile, Identified ] , idesc = "" , ikit = [] } odorDistressing = ItemKind { isymbol = '\'' , iname = "distressing whiff" , ifreq = [("distressing odor", 1)] , iflavour = zipFancy [BrRed] , icount = 10 , irarity = [(1, 1)] , iverbHit = "distress" , iweight = 1 , iaspects = [] , ieffects = [OverfillCalm (-20)] , 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 = 9 , 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 = [] } mistHealing2 = ItemKind { isymbol = '\'' , iname = "mist" , ifreq = [("healing mist 2", 1)] , iflavour = zipFancy [White] , icount = 8 , irarity = [(1, 1)] , iverbHit = "revitalize" , iweight = 1 , iaspects = [AddLight 2] , ieffects = [RefillHP 4] , 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 = 7 , 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 = 6 , 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 = 18 , irarity = [(1, 1)] , iverbHit = "splosh" , iweight = 50 , iaspects = [] , ieffects = [RefillHP (-1)] , ifeature = [ ToThrow $ ThrowMod 28 10 -- 2 steps, one turn , Fragile, Identified ] , idesc = "" , ikit = [] } glassPiece = ItemKind -- when blowing up windows { isymbol = '*' , iname = "glass piece" , ifreq = [("glass piece", 1)] , iflavour = zipPlain [BrBlue] , icount = 18 , 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)] , 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 = 21 , 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 = 20 , irarity = [(1, 1)] , iverbHit = "glue" , iweight = 20 , iaspects = [] , ieffects = [Paralyze (3 + d 3)] , ifeature = [toVelocity 40, Fragile, Identified] , idesc = "" , ikit = [] } spark = ItemKind { isymbol = '\'' , iname = "spark" , ifreq = [("spark", 1)] , iflavour = zipPlain [BrYellow] , icount = 17 , irarity = [(1, 1)] , iverbHit = "burn" , iweight = 1 , iaspects = [AddLight 4] , ieffects = [Burn 1] , ifeature = [Fragile, toLinger 10, Identified] , idesc = "" , ikit = [] } mistAntiSlow = ItemKind { isymbol = '\'' , iname = "mist" , ifreq = [("anti-slow mist", 1)] , iflavour = zipPlain [BrRed] , icount = 7 , irarity = [(1, 1)] , iverbHit = "propel" , iweight = 1 , iaspects = [] , ieffects = [DropItem COrgan "slow 10" True] , ifeature = [ toVelocity 7 -- the slowest that gets anywhere (1 step only) , Fragile, Identified ] , idesc = "" , ikit = [] } mistAntidote = ItemKind { isymbol = '\'' , iname = "mist" , ifreq = [("antidote mist", 1)] , iflavour = zipPlain [BrBlue] , icount = 8 , irarity = [(1, 1)] , iverbHit = "cure" , iweight = 1 , iaspects = [] , ieffects = [DropItem COrgan "poisoned" True] , ifeature = [ toVelocity 7 -- the slowest that gets anywhere (1 step only) , Fragile, Identified ] , idesc = "" , ikit = [] } -- * Assorted temporary condition blasts mistStrength = ItemKind { isymbol = '\'' , iname = "mist" , ifreq = [("strength mist", 1)] , iflavour = zipFancy [Red] , icount = 6 , irarity = [(1, 1)] , iverbHit = "strengthen" , iweight = 1 , iaspects = [] , ieffects = [toOrganActorTurn "strengthened" (3 + d 3)] , ifeature = [ toVelocity 7 -- the slowest that gets anywhere (1 step only) , Fragile, Identified ] , idesc = "" , ikit = [] } mistWeakness = ItemKind { isymbol = '\'' , iname = "mist" , ifreq = [("weakness mist", 1)] , iflavour = zipFancy [Blue] , icount = 5 , irarity = [(1, 1)] , iverbHit = "weaken" , iweight = 1 , iaspects = [] , ieffects = [toOrganGameTurn "weakened" (3 + d 3)] , ifeature = [ toVelocity 7 -- the slowest that gets anywhere (1 step only) , Fragile, Identified ] , idesc = "" , ikit = [] } protectingBalm = ItemKind { isymbol = '\'' , iname = "balm droplet" , ifreq = [("protecting balm", 1)] , iflavour = zipPlain [Brown] , icount = 13 , irarity = [(1, 1)] , iverbHit = "balm" , iweight = 1 , iaspects = [] , ieffects = [toOrganActorTurn "protected" (3 + d 3)] , ifeature = [ toVelocity 13 -- the slowest that travels at least 2 steps , Fragile, Identified ] , idesc = "" , ikit = [] } vulnerabilityBalm = ItemKind { isymbol = '\'' , iname = "PhD defense question" , ifreq = [("PhD defense question", 1)] , iflavour = zipPlain [BrRed] , icount = 14 , irarity = [(1, 1)] , iverbHit = "nag" , iweight = 1 , iaspects = [] , ieffects = [toOrganGameTurn "defenseless" (3 + d 3)] , ifeature = [ toVelocity 13 -- the slowest that travels at least 2 steps , Fragile, Identified ] , idesc = "" , ikit = [] } hasteSpray = ItemKind { isymbol = '\'' , iname = "haste spray" , ifreq = [("haste spray", 1)] , iflavour = zipPlain [BrRed] , icount = 15 , irarity = [(1, 1)] , iverbHit = "haste" , iweight = 1 , iaspects = [] , ieffects = [toOrganActorTurn "fast 20" (3 + d 3)] , ifeature = [ toVelocity 13 -- the slowest that travels at least 2 steps , Fragile, Identified ] , idesc = "" , ikit = [] } slownessSpray = ItemKind { isymbol = '\'' , iname = "slowness spray" , ifreq = [("slowness spray", 1)] , iflavour = zipPlain [BrBlue] , icount = 16 , irarity = [(1, 1)] , iverbHit = "slow" , iweight = 1 , iaspects = [] , ieffects = [toOrganGameTurn "slow 10" (3 + d 3)] , ifeature = [ toVelocity 13 -- the slowest that travels at least 2 steps , Fragile, Identified ] , idesc = "" , ikit = [] } eyeDrop = ItemKind { isymbol = '\'' , iname = "eye drop" , ifreq = [("eye drop", 1)] , iflavour = zipPlain [BrGreen] , icount = 17 , irarity = [(1, 1)] , iverbHit = "cleanse" , iweight = 1 , iaspects = [] , ieffects = [toOrganActorTurn "far-sighted" (3 + d 3)] , ifeature = [ toVelocity 13 -- the slowest that travels at least 2 steps , Fragile, Identified ] , idesc = "" , ikit = [] } smellyDroplet = ItemKind { isymbol = '\'' , iname = "smelly droplet" , ifreq = [("smelly droplet", 1)] , iflavour = zipPlain [Blue] , icount = 18 , irarity = [(1, 1)] , iverbHit = "sensitize" , iweight = 1 , iaspects = [] , ieffects = [toOrganActorTurn "keen-smelling" (3 + d 3)] , ifeature = [ toVelocity 13 -- the slowest that travels at least 2 steps , Fragile, Identified ] , idesc = "" , ikit = [] } whiskeySpray = ItemKind { isymbol = '\'' , iname = "whiskey spray" , ifreq = [("whiskey spray", 1)] , iflavour = zipPlain [Brown] , icount = 19 , irarity = [(1, 1)] , iverbHit = "inebriate" , iweight = 1 , iaspects = [] , ieffects = [toOrganActorTurn "drunk" (3 + d 3)] , ifeature = [ toVelocity 13 -- the slowest that travels at least 2 steps , Fragile, Identified ] , idesc = "" , ikit = [] } LambdaHack-0.5.0.0/GameDefinition/Content/ItemKindOrgan.hs0000644000000000000000000002703612555256425021355 0ustar0000000000000000-- | Organ definitions. module Content.ItemKindOrgan ( organs ) where import qualified Data.EnumMap.Strict as EM import Game.LambdaHack.Common.Ability import Game.LambdaHack.Common.Color import Game.LambdaHack.Common.Dice import Game.LambdaHack.Common.Flavour import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.Msg import Game.LambdaHack.Content.ItemKind organs :: [ItemKind] organs = [fist, foot, claw, smallClaw, snout, smallJaw, jaw, largeJaw, tooth, horn, tentacle, lash, noseTip, lip, torsionRight, torsionLeft, thorn, boilingFissure, arsenicFissure, sulfurFissure, beeSting, sting, venomTooth, venomFang, screechingBeak, largeTail, pupil, armoredSkin, eye2, eye3, eye4, eye5, eye6, eye7, eye8, vision4, vision6, vision8, vision10, vision12, vision14, vision16, nostril, insectMortality, sapientBrain, animalBrain, speedGland2, speedGland4, speedGland6, speedGland8, speedGland10, scentGland, boilingVent, arsenicVent, sulfurVent, bonusHP] fist, foot, claw, smallClaw, snout, smallJaw, jaw, largeJaw, tooth, horn, tentacle, lash, noseTip, lip, torsionRight, torsionLeft, thorn, boilingFissure, arsenicFissure, sulfurFissure, beeSting, sting, venomTooth, venomFang, screechingBeak, largeTail, pupil, armoredSkin, eye2, eye3, eye4, eye5, eye6, eye7, eye8, vision4, vision6, vision8, vision10, vision12, vision14, vision16, nostril, insectMortality, sapientBrain, animalBrain, speedGland2, speedGland4, speedGland6, speedGland8, speedGland10, scentGland, boilingVent, arsenicVent, sulfurVent, bonusHP :: ItemKind -- Weapons -- * Human weapon organs fist = ItemKind { isymbol = '%' , iname = "fist" , ifreq = [("fist", 100)] , iflavour = zipPlain [Red] , icount = 2 , irarity = [(1, 1)] , iverbHit = "punch" , iweight = 2000 , iaspects = [] , ieffects = [Hurt (4 * d 1)] , ifeature = [Durable, Identified] , idesc = "" , ikit = [] } foot = fist { iname = "foot" , ifreq = [("foot", 50)] , icount = 2 , 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 = "hook" , iaspects = [Timeout $ 4 + d 4] , ieffects = [Hurt (2 * d 1), Recharging (toOrganGameTurn "slow 10" 2)] , idesc = "" } smallClaw = fist { iname = "small claw" , ifreq = [("small claw", 50)] , icount = 2 , iverbHit = "slash" , ieffects = [Hurt (2 * d 1)] , idesc = "" } snout = fist { iname = "snout" , ifreq = [("snout", 10)] , iverbHit = "bite" , ieffects = [Hurt (2 * d 1)] , idesc = "" } smallJaw = fist { iname = "small jaw" , ifreq = [("small jaw", 20)] , icount = 1 , iverbHit = "rip" , ieffects = [Hurt (3 * d 1)] , idesc = "" } jaw = fist { iname = "jaw" , ifreq = [("jaw", 20)] , icount = 1 , iverbHit = "rip" , ieffects = [Hurt (5 * d 1)] , idesc = "" } largeJaw = fist { iname = "large jaw" , ifreq = [("large jaw", 100)] , icount = 1 , iverbHit = "crush" , ieffects = [Hurt (12 * d 1)] , idesc = "" } tooth = fist { iname = "tooth" , ifreq = [("tooth", 20)] , icount = 3 , iverbHit = "nail" , ieffects = [Hurt (2 * d 1)] , idesc = "" } horn = fist { iname = "horn" , ifreq = [("horn", 20)] , icount = 2 , iverbHit = "impale" , ieffects = [Hurt (8 * d 1)] , idesc = "" } -- * Monster weapon organs tentacle = fist { iname = "tentacle" , ifreq = [("tentacle", 50)] , icount = 4 , iverbHit = "slap" , ieffects = [Hurt (4 * d 1)] , idesc = "" } lash = fist { iname = "lash" , ifreq = [("lash", 100)] , icount = 1 , iverbHit = "lash" , iaspects = [] , ieffects = [Hurt (3 * d 1)] , idesc = "" } noseTip = fist { iname = "tip" , ifreq = [("nose tip", 50)] , icount = 1 , iverbHit = "poke" , ieffects = [Hurt (2 * d 1)] , idesc = "" } lip = fist { iname = "lip" , ifreq = [("lip", 10)] , icount = 1 , iverbHit = "lap" , iaspects = [Timeout $ 3 + d 3] , ieffects = [ Hurt (1 * d 1) , Recharging (toOrganGameTurn "weakened" (2 + d 2)) ] , idesc = "" } torsionRight = fist { iname = "right torsion" , ifreq = [("right torsion", 100)] , icount = 1 , iverbHit = "twist" , iaspects = [Timeout $ 5 + d 5] , ieffects = [ Hurt (17 * d 1) , Recharging (toOrganGameTurn "slow 10" (3 + d 3)) ] , idesc = "" } torsionLeft = fist { iname = "left torsion" , ifreq = [("left torsion", 100)] , icount = 1 , iverbHit = "twist" , iaspects = [Timeout $ 5 + d 5] , ieffects = [ Hurt (17 * d 1) , Recharging (toOrganGameTurn "weakened" (3 + d 3)) ] , idesc = "" } -- * Special weapon organs thorn = fist { iname = "thorn" , ifreq = [("thorn", 100)] , icount = 2 + d 3 , iverbHit = "impale" , ieffects = [Hurt (2 * d 1)] , ifeature = [Identified] -- not Durable , idesc = "" } boilingFissure = fist { iname = "fissure" , ifreq = [("boiling fissure", 100)] , icount = 5 + d 5 , iverbHit = "hiss at" , ieffects = [Burn $ 1 * d 1] , ifeature = [Identified] -- not Durable , idesc = "" } arsenicFissure = boilingFissure { iname = "fissure" , ifreq = [("arsenic fissure", 100)] , icount = 2 + d 2 , ieffects = [Burn $ 1 * d 1, toOrganGameTurn "weakened" (2 + d 2)] } sulfurFissure = boilingFissure { iname = "fissure" , ifreq = [("sulfur fissure", 100)] , icount = 2 + d 2 , ieffects = [Burn $ 1 * d 1, RefillHP 6] } beeSting = fist { iname = "bee sting" , ifreq = [("bee sting", 100)] , icount = 1 , iverbHit = "sting" , iaspects = [AddArmorMelee 90, AddArmorRanged 90] , ieffects = [Burn $ 2 * d 1, Paralyze 3, RefillHP 5] , ifeature = [Identified] -- not Durable , idesc = "Painful, but beneficial." } sting = fist { iname = "sting" , ifreq = [("sting", 100)] , icount = 1 , iverbHit = "sting" , iaspects = [Timeout $ 1 + d 5] , ieffects = [Burn $ 2 * d 1, Recharging (Paralyze 2)] , idesc = "Painful, debilitating and harmful." } venomTooth = fist { iname = "venom tooth" , ifreq = [("venom tooth", 100)] , icount = 2 , iverbHit = "bite" , iaspects = [Timeout $ 5 + d 3] , ieffects = [ Hurt (2 * d 1) , Recharging (toOrganGameTurn "slow 10" (3 + d 3)) ] , idesc = "" } -- TODO: should also confer poison resistance, but current implementation -- is too costly (poison removal each turn) venomFang = fist { iname = "venom fang" , ifreq = [("venom fang", 100)] , icount = 2 , iverbHit = "bite" , iaspects = [Timeout $ 7 + d 5] , ieffects = [ Hurt (2 * d 1) , Recharging (toOrganNone "poisoned") ] , idesc = "" } screechingBeak = armoredSkin { iname = "screeching beak" , ifreq = [("screeching beak", 100)] , icount = 1 , iverbHit = "peck" , iaspects = [Timeout $ 5 + d 5] , ieffects = [ Recharging (Summon [("scavenger", 1)] $ 1 + dl 2) , Hurt (2 * d 1) ] , idesc = "" } largeTail = fist { iname = "large tail" , ifreq = [("large tail", 50)] , icount = 1 , iverbHit = "knock" , iaspects = [Timeout $ 1 + d 3] , ieffects = [Hurt (8 * d 1), Recharging (PushActor (ThrowMod 400 25))] , idesc = "" } pupil = fist { iname = "pupil" , ifreq = [("pupil", 100)] , icount = 1 , iverbHit = "gaze at" , iaspects = [AddSight 10, Timeout $ 5 + d 5] , ieffects = [ Hurt (1 * d 1) , Recharging (DropItem COrgan "temporary conditions" True) , Recharging $ RefillHP (-2) ] , idesc = "" } -- Non-weapons -- * Armor organs armoredSkin = ItemKind { isymbol = '%' , iname = "armored skin" , ifreq = [("armored skin", 100)] , iflavour = zipPlain [Red] , icount = 1 , irarity = [(1, 1)] , iverbHit = "bash" , iweight = 2000 , iaspects = [AddArmorMelee 30, AddArmorRanged 30] , ieffects = [] , ifeature = [Durable, Identified] , idesc = "" , ikit = [] } -- * Sense organs eye :: Int -> ItemKind eye n = armoredSkin { iname = "eye" , ifreq = [(toGroupName $ "eye" <+> tshow n, 100)] , icount = 2 , iverbHit = "glare at" , iaspects = [AddSight (intToDice n)] , idesc = "" } eye2 = eye 2 eye3 = eye 3 eye4 = eye 4 eye5 = eye 5 eye6 = eye 6 eye7 = eye 7 eye8 = eye 8 vision :: Int -> ItemKind vision n = armoredSkin { iname = "vision" , ifreq = [(toGroupName $ "vision" <+> tshow n, 100)] , icount = 1 , iverbHit = "visualize" , iaspects = [AddSight (intToDice n)] , idesc = "" } vision4 = vision 4 vision6 = vision 6 vision8 = vision 8 vision10 = vision 10 vision12 = vision 12 vision14 = vision 14 vision16 = vision 16 nostril = armoredSkin { iname = "nostril" , ifreq = [("nostril", 100)] , icount = 2 , iverbHit = "snuff" , iaspects = [AddSmell 1] -- times 2, from icount , idesc = "" } -- * Assorted insectMortality = fist { iname = "insect mortality" , ifreq = [("insect mortality", 100)] , icount = 1 , iverbHit = "age" , iaspects = [Periodic, Timeout $ 40 + d 10] , ieffects = [Recharging (RefillHP (-1))] , idesc = "" } sapientBrain = armoredSkin { iname = "sapient brain" , ifreq = [("sapient brain", 100)] , icount = 1 , iverbHit = "outbrain" , iaspects = [AddSkills unitSkills] , idesc = "" } animalBrain = armoredSkin { iname = "animal brain" , ifreq = [("animal brain", 100)] , icount = 1 , iverbHit = "blank" , iaspects = [let absNo = [AbDisplace, AbMoveItem, AbProject, AbApply] sk = EM.fromList $ zip absNo [-1, -1..] in AddSkills $ addSkills unitSkills sk] , idesc = "" } speedGland :: Int -> ItemKind speedGland n = armoredSkin { iname = "speed gland" , ifreq = [(toGroupName $ "speed gland" <+> tshow n, 100)] , icount = 1 , iverbHit = "spit at" , iaspects = [ AddSpeed $ intToDice n , Periodic , Timeout $ intToDice $ 100 `div` n ] , ieffects = [Recharging (RefillHP 1)] , idesc = "" } speedGland2 = speedGland 2 speedGland4 = speedGland 4 speedGland6 = speedGland 6 speedGland8 = speedGland 8 speedGland10 = speedGland 10 scentGland = armoredSkin -- TODO: cone attack, 3m away, project? apply? { iname = "scent gland" , ifreq = [("scent gland", 100)] , icount = 1 , iverbHit = "spray at" , iaspects = [Periodic, Timeout $ 10 + d 2 |*| 5 ] , ieffects = [ Recharging (Explode "distressing odor") , Recharging ApplyPerfume ] , idesc = "" } boilingVent = armoredSkin { iname = "vent" , ifreq = [("boiling vent", 100)] , iflavour = zipPlain [Blue] , icount = 1 , iverbHit = "menace" , iaspects = [Periodic, Timeout $ 2 + d 2 |*| 5] , ieffects = [Recharging (Explode "boiling water")] , idesc = "" } arsenicVent = boilingVent { iname = "vent" , ifreq = [("arsenic vent", 100)] , iflavour = zipPlain [Cyan] , iaspects = [Periodic, Timeout $ 2 + d 2 |*| 5] , ieffects = [Recharging (Explode "weakness mist")] } sulfurVent = boilingVent { iname = "vent" , ifreq = [("sulfur vent", 100)] , iflavour = zipPlain [BrYellow] , iaspects = [Periodic, Timeout $ 2 + d 2 |*| 5] , ieffects = [Recharging (Explode "strength mist")] } bonusHP = armoredSkin { iname = "bonus HP" , ifreq = [("bonus HP", 100)] , icount = 1 , iverbHit = "intimidate" , iweight = 0 , iaspects = [AddMaxHP 1] , idesc = "" } LambdaHack-0.5.0.0/GameDefinition/Content/ItemKind.hs0000644000000000000000000011254512555256425020366 0ustar0000000000000000-- | Item and treasure definitions. module Content.ItemKind ( cdefs ) where import qualified Data.EnumMap.Strict as EM import Data.List import Content.ItemKindActor import Content.ItemKindBlast import Content.ItemKindOrgan import Content.ItemKindTemporary import Game.LambdaHack.Common.Ability import Game.LambdaHack.Common.Color import Game.LambdaHack.Common.ContentDef import Game.LambdaHack.Common.Dice 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 , validateSingle = validateSingleItemKind , validateAll = validateAllItemKind , content = items ++ organs ++ blasts ++ actors ++ temporaries } items :: [ItemKind] items = [dart, dart200, paralizingProj, harpoon, net, jumpingPole, sharpeningTool, seeingItem, light1, light2, light3, gorget, necklace1, necklace2, necklace3, necklace4, necklace5, necklace6, necklace7, necklace8, necklace9, sightSharpening, ring1, ring2, ring3, ring4, ring5, ring6, ring7, ring8, potion1, potion2, potion3, potion4, potion5, potion6, potion7, potion8, potion9, flask1, flask2, flask3, flask4, flask5, flask6, flask7, flask8, flask9, flask10, flask11, flask12, flask13, flask14, scroll1, scroll2, scroll3, scroll4, scroll5, scroll6, scroll7, scroll8, scroll9, scroll10, scroll11, armorLeather, armorMail, gloveFencing, gloveGauntlet, gloveJousting, buckler, shield, dagger, daggerDropBestWeapon, hammer, hammerParalyze, hammerSpark, sword, swordImpress, swordNullify, halberd, halberdPushActor, wand1, wand2, gem1, gem2, gem3, gem4, currency] dart, dart200, paralizingProj, harpoon, net, jumpingPole, sharpeningTool, seeingItem, light1, light2, light3, gorget, necklace1, necklace2, necklace3, necklace4, necklace5, necklace6, necklace7, necklace8, necklace9, sightSharpening, ring1, ring2, ring3, ring4, ring5, ring6, ring7, ring8, potion1, potion2, potion3, potion4, potion5, potion6, potion7, potion8, potion9, flask1, flask2, flask3, flask4, flask5, flask6, flask7, flask8, flask9, flask10, flask11, flask12, flask13, flask14, scroll1, scroll2, scroll3, scroll4, scroll5, scroll6, scroll7, scroll8, scroll9, scroll10, scroll11, armorLeather, armorMail, gloveFencing, gloveGauntlet, gloveJousting, buckler, shield, dagger, daggerDropBestWeapon, hammer, hammerParalyze, hammerSpark, sword, swordImpress, swordNullify, halberd, halberdPushActor, wand1, wand2, gem1, gem2, gem3, gem4, currency :: ItemKind necklace, ring, potion, flask, scroll, wand, gem :: ItemKind -- generic templates -- * Item group symbols, partially from Nethack symbolProjectile, _symbolLauncher, symbolLight, symbolTool, symbolGem, symbolGold, symbolNecklace, symbolRing, symbolPotion, symbolFlask, symbolScroll, symbolTorsoArmor, symbolMiscArmor, _symbolClothes, symbolShield, symbolPolearm, symbolEdged, symbolHafted, symbolWand, _symbolStaff, _symbolFood :: Char symbolProjectile = '|' _symbolLauncher = '}' symbolLight = '(' symbolTool = '(' symbolGem = '*' symbolGold = '$' symbolNecklace = '"' symbolRing = '=' symbolPotion = '!' -- concoction, bottle, jar, vial, canister symbolFlask = '!' symbolScroll = '?' -- book, note, tablet, remote symbolTorsoArmor = '[' symbolMiscArmor = '[' _symbolClothes = '(' symbolShield = '[' symbolPolearm = ')' symbolEdged = ')' symbolHafted = ')' symbolWand = '/' -- magical rod, transmitter, pistol, rifle _symbolStaff = '_' -- scanner _symbolFood = ',' -- too easy to miss? -- * Thrown weapons dart = ItemKind { isymbol = symbolProjectile , iname = "dart" , ifreq = [("useful", 100), ("any arrow", 100)] , iflavour = zipPlain [Cyan] , icount = 4 * d 3 , irarity = [(1, 10), (10, 20)] , iverbHit = "nick" , iweight = 50 , iaspects = [AddHurtRanged (d 3 + dl 6 |*| 20)] , ieffects = [Hurt (2 * d 1)] , ifeature = [Identified] , 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 = symbolProjectile , iname = "fine dart" , ifreq = [("useful", 100), ("any arrow", 50)] -- TODO: until arrows added , iflavour = zipPlain [BrRed] , icount = 4 * d 3 , irarity = [(1, 20), (10, 10)] , iverbHit = "prick" , iweight = 50 , iaspects = [AddHurtRanged (d 3 + dl 6 |*| 20)] , ieffects = [Hurt (1 * d 1)] , ifeature = [toVelocity 200, Identified] , idesc = "Finely balanced for throws of great speed." , ikit = [] } -- * Exotic thrown weapons paralizingProj = ItemKind { isymbol = symbolProjectile , 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), DropBestWeapon] , ifeature = [Identified] , idesc = "Wood balls tied with hemp rope. The target enemy is tripped and bound to drop the main weapon, while fighting for balance." , ikit = [] } harpoon = ItemKind { isymbol = symbolProjectile , iname = "harpoon" , ifreq = [("useful", 100)] , iflavour = zipPlain [Brown] , icount = dl 5 , irarity = [(10, 10)] , iverbHit = "hook" , iweight = 4000 , iaspects = [AddHurtRanged (d 2 + dl 5 |*| 20)] , ieffects = [Hurt (4 * d 1), PullActor (ThrowMod 200 50)] , ifeature = [Identified] , 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 = symbolProjectile , iname = "net" , ifreq = [("useful", 100)] , iflavour = zipPlain [White] , icount = dl 3 , irarity = [(3, 5), (10, 4)] , iverbHit = "entangle" , iweight = 1000 , iaspects = [] , ieffects = [ toOrganGameTurn "slow 10" (3 + d 3) , DropItem CEqp "torso armor" False ] , ifeature = [Identified] , idesc = "A wide net with weights along the edges. Entangles armor and restricts movement." , ikit = [] } -- * Assorted tools jumpingPole = ItemKind { isymbol = symbolTool , iname = "jumping pole" , ifreq = [("useful", 100)] , iflavour = zipPlain [White] , icount = 1 , irarity = [(1, 2)] , iverbHit = "prod" , iweight = 10000 , iaspects = [Timeout $ d 2 + 2 - dl 2 |*| 10] , ieffects = [Recharging (toOrganActorTurn "fast 20" 1)] , ifeature = [Durable, Applicable, Identified] , idesc = "Makes you vulnerable at take-off, but then you are free like a bird." , ikit = [] } sharpeningTool = ItemKind { isymbol = symbolTool , iname = "whetstone" , ifreq = [("useful", 100)] , iflavour = zipPlain [Blue] , icount = 1 , irarity = [(10, 10)] , iverbHit = "smack" , iweight = 400 , iaspects = [AddHurtMelee $ d 10 |*| 3] , 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." , ikit = [] } seeingItem = ItemKind { isymbol = '%' , iname = "pupil" , ifreq = [("useful", 100)] , iflavour = zipPlain [Red] , icount = 1 , irarity = [(1, 1)] , iverbHit = "gaze at" , iweight = 100 , iaspects = [ AddSight 10, AddMaxCalm 60, AddLight 2 , Periodic, Timeout $ 1 + d 2 ] , ieffects = [ Recharging (toOrganNone "poisoned") , Recharging (Summon [("mobile monster", 1)] 1) ] , ifeature = [Identified] , idesc = "A slimy, dilated green pupil torn out from some giant eye. Clear and focused, as if still alive." , ikit = [] } -- * Lights light1 = ItemKind { isymbol = symbolLight , iname = "wooden torch" , ifreq = [("useful", 100), ("light source", 100)] , iflavour = zipPlain [Brown] , icount = d 2 , irarity = [(1, 10)] , iverbHit = "scorch" , iweight = 1200 , iaspects = [ AddLight 3 -- not only flashes, but also sparks , AddSight (-2) ] -- unused by AI due to the mixed blessing , ieffects = [Burn 2] , ifeature = [EqpSlot EqpSlotAddLight "", Identified] , idesc = "A smoking, heavy wooden torch, burning in an unsteady glow." , ikit = [] } light2 = ItemKind { isymbol = symbolLight , iname = "oil lamp" , ifreq = [("useful", 100), ("light source", 100)] , iflavour = zipPlain [BrYellow] , icount = 1 , irarity = [(6, 7)] , 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 = [] } light3 = ItemKind { isymbol = symbolLight , iname = "brass lantern" , ifreq = [("useful", 100), ("light source", 100)] , iflavour = zipPlain [BrWhite] , icount = 1 , irarity = [(10, 5)] , 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 = [] } -- * Periodic jewelry gorget = ItemKind { isymbol = symbolNecklace , iname = "Old Gorget" , ifreq = [("useful", 100)] , iflavour = zipFancy [BrCyan] , icount = 1 , irarity = [(4, 3), (10, 3)] -- weak, shallow , iverbHit = "whip" , iweight = 30 , iaspects = [ Unique , Periodic , Timeout $ 1 + d 2 , AddArmorMelee $ 2 + d 3 , AddArmorRanged $ 2 + d 3 ] , ieffects = [Recharging (RefillCalm 1)] , ifeature = [ Durable, 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 = symbolNecklace , iname = "necklace" , ifreq = [("useful", 100)] , iflavour = zipFancy stdCol ++ zipPlain brightCol , icount = 1 , irarity = [(10, 2)] , iverbHit = "whip" , iweight = 30 , iaspects = [Periodic] , 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 { ifreq = [("treasure", 100)] , iaspects = [Unique, Timeout $ d 3 + 4 - dl 3 |*| 10] ++ iaspects necklace , ieffects = [NoEffect "of Aromata", Recharging (RefillHP 1)] , ifeature = Durable : ifeature necklace , idesc = "A cord of freshly dried herbs and healing berries." } necklace2 = necklace { ifreq = [("treasure", 100)] -- just too nasty to call it useful , irarity = [(1, 1)] , iaspects = (Timeout $ d 3 + 3 - dl 3 |*| 10) : iaspects necklace , ieffects = [ Recharging Impress , Recharging (DropItem COrgan "temporary conditions" True) , Recharging (Summon [("mobile animal", 1)] $ 1 + dl 2) , Recharging (Explode "waste") ] } necklace3 = necklace { iaspects = (Timeout $ d 3 + 3 - dl 3 |*| 10) : iaspects necklace , ieffects = [Recharging (Paralyze $ 5 + d 5 + dl 5)] } necklace4 = necklace { iaspects = (Timeout $ d 4 + 4 - dl 4 |*| 2) : iaspects necklace , ieffects = [Recharging (Teleport $ d 2 * 3)] } necklace5 = necklace { iaspects = (Timeout $ d 3 + 4 - dl 3 |*| 10) : iaspects necklace , ieffects = [Recharging (Teleport $ 14 + d 3 * 3)] } necklace6 = necklace { iaspects = (Timeout $ d 4 |*| 10) : iaspects necklace , ieffects = [Recharging (PushActor (ThrowMod 100 50))] } necklace7 = necklace -- TODO: teach AI to wear only for fight { ifreq = [("treasure", 100)] , iaspects = [ Unique, AddMaxHP $ 10 + d 10 , AddArmorMelee 20, AddArmorRanged 20 , Timeout $ d 2 + 5 - dl 3 ] ++ iaspects necklace , ieffects = [ NoEffect "of Overdrive" , Recharging (InsertMove $ 1 + d 2) , Recharging (RefillHP (-1)) , Recharging (RefillCalm (-1)) ] , ifeature = Durable : ifeature necklace } necklace8 = necklace { iaspects = (Timeout $ d 3 + 3 - dl 3 |*| 5) : iaspects necklace , ieffects = [Recharging $ Explode "spark"] } necklace9 = necklace { iaspects = (Timeout $ d 3 + 3 - dl 3 |*| 5) : iaspects necklace , ieffects = [Recharging $ Explode "fragrance"] } -- * Non-periodic jewelry sightSharpening = ItemKind { isymbol = symbolRing , iname = "Sharp Monocle" , ifreq = [("treasure", 100)] , iflavour = zipPlain [White] , icount = 1 , irarity = [(7, 3), (10, 3)] -- medium weak, medium shallow , iverbHit = "rap" , iweight = 50 , iaspects = [Unique, AddSight $ 1 + d 2, AddHurtMelee $ d 2 |*| 3] , ieffects = [] , ifeature = [ Precious, Identified, Durable , EqpSlot EqpSlotAddSight "" ] , idesc = "Let's you better focus your weaker eye." , ikit = [] } -- 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 inv or even activating a wrong item via letter by mistake. ring = ItemKind { isymbol = symbolRing , iname = "ring" , ifreq = [("useful", 100)] , iflavour = zipPlain stdCol ++ zipFancy darkCol , icount = 1 , irarity = [(10, 3)] , iverbHit = "knock" , iweight = 15 , iaspects = [] , ieffects = [Explode "blast 20"] , 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." , ikit = [] } ring1 = ring { irarity = [(10, 2)] , iaspects = [AddSpeed $ 1 + d 2, AddMaxHP $ dl 7 - 7 - d 7] , ieffects = [Explode "distortion"] -- strong magic , ifeature = ifeature ring ++ [EqpSlot EqpSlotAddSpeed ""] } ring2 = ring { irarity = [(10, 5)] , iaspects = [AddMaxHP $ 10 + dl 10, AddMaxCalm $ dl 5 - 20 - d 5] , ifeature = ifeature ring ++ [EqpSlot EqpSlotAddMaxHP ""] } ring3 = ring { irarity = [(10, 5)] , iaspects = [AddMaxCalm $ 29 + 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 { irarity = [(3, 3), (10, 5)] , iaspects = [AddHurtMelee $ d 5 + dl 5 |*| 3, AddMaxHP $ dl 3 - 5 - d 3] , ifeature = ifeature ring ++ [EqpSlot EqpSlotAddHurtMelee ""] } ring5 = ring -- by the time it's found, probably no space in eqp { irarity = [(5, 0), (10, 2)] , iaspects = [AddLight $ d 2] , ieffects = [Explode "distortion"] -- strong magic , ifeature = ifeature ring ++ [EqpSlot EqpSlotAddLight ""] , idesc = "A sturdy ring with a large, shining stone." } ring6 = ring { ifreq = [("treasure", 100)] , irarity = [(10, 2)] , iaspects = [ Unique, AddSpeed $ 3 + d 4 , AddMaxCalm $ - 20 - d 20, AddMaxHP $ - 20 - d 20 ] , ieffects = [NoEffect "of Rush"] -- no explosion, because Durable , ifeature = ifeature ring ++ [Durable, EqpSlot EqpSlotAddSpeed ""] } ring7 = ring { ifreq = [("useful", 100), ("ring of opportunity sniper", 1) ] , irarity = [(1, 1)] , iaspects = [AddSkills $ EM.fromList [(AbProject, 8)]] , ieffects = [ NoEffect "of opportunity sniper" , Explode "distortion" ] -- strong magic , ifeature = ifeature ring ++ [EqpSlot (EqpSlotAddSkills AbProject) ""] } ring8 = ring { ifreq = [("useful", 1), ("ring of opportunity grenadier", 1) ] , irarity = [(1, 1)] , iaspects = [AddSkills $ EM.fromList [(AbProject, 11)]] , ieffects = [ NoEffect "of opportunity grenadier" , Explode "distortion" ] -- strong magic , ifeature = ifeature ring ++ [EqpSlot (EqpSlotAddSkills AbProject) ""] } -- * Ordinary exploding consumables, often intended to be thrown potion = ItemKind { isymbol = symbolPotion , iname = "potion" , ifreq = [("useful", 100)] , iflavour = zipLiquid brightCol ++ zipPlain brightCol ++ zipFancy brightCol , icount = 1 , irarity = [(1, 12), (10, 9)] , iverbHit = "splash" , iweight = 200 , iaspects = [] , ieffects = [] , ifeature = [ toVelocity 50 -- oily, bad grip , Applicable, Fragile ] , idesc = "A vial of bright, frothing concoction." -- purely natural; no maths, no magic , ikit = [] } potion1 = potion { ieffects = [ NoEffect "of rose water", Impress, RefillCalm (-3) , OnSmash ApplyPerfume, OnSmash (Explode "fragrance") ] } potion2 = potion { ifreq = [("treasure", 100)] , irarity = [(6, 10), (10, 10)] , iaspects = [Unique] , ieffects = [ NoEffect "of Attraction", Impress, OverfillCalm (-20) , OnSmash (Explode "pheromone") ] } potion3 = potion { irarity = [(1, 10)] , ieffects = [ RefillHP 5, DropItem COrgan "poisoned" True , OnSmash (Explode "healing mist") ] } potion4 = potion { irarity = [(10, 10)] , ieffects = [ RefillHP 10, DropItem COrgan "poisoned" True , OnSmash (Explode "healing mist 2") ] } potion5 = potion { ieffects = [ OneOf [ OverfillHP 10, OverfillHP 5, Burn 5 , toOrganActorTurn "strengthened" (20 + d 5) ] , OnSmash (OneOf [ Explode "healing mist" , Explode "wounding mist" , Explode "fragrance" , Explode "smelly droplet" , Explode "blast 10" ]) ] } potion6 = potion { irarity = [(3, 3), (10, 6)] , ieffects = [ Impress , OneOf [ OverfillCalm (-60) , OverfillHP 20, OverfillHP 10, Burn 10 , toOrganActorTurn "fast 20" (20 + d 5) ] , OnSmash (OneOf [ Explode "healing mist 2" , Explode "calming mist" , Explode "distressing odor" , Explode "eye drop" , Explode "blast 20" ]) ] } potion7 = potion { irarity = [(1, 15), (10, 5)] , ieffects = [ DropItem COrgan "poisoned" True , OnSmash (Explode "antidote mist") ] } potion8 = potion { irarity = [(1, 5), (10, 15)] , ieffects = [ DropItem COrgan "temporary conditions" True , OnSmash (Explode "blast 10") ] } potion9 = potion { ifreq = [("treasure", 100)] , irarity = [(10, 5)] , iaspects = [Unique] , ieffects = [ NoEffect "of Love", OverfillHP 60 , Impress, OverfillCalm (-60) , OnSmash (Explode "healing mist 2") , OnSmash (Explode "pheromone") ] } -- * Exploding consumables with temporary aspects, can be thrown -- TODO: dip projectiles in those -- TODO: add flavour and realism as in, e.g., "flask of whiskey", -- which is more flavourful and believable than "flask of strength" flask = ItemKind { isymbol = symbolFlask , iname = "flask" , ifreq = [("useful", 100), ("flask", 100)] , iflavour = zipLiquid darkCol ++ zipPlain darkCol ++ zipFancy darkCol , icount = 1 , irarity = [(1, 9), (10, 6)] , iverbHit = "splash" , iweight = 500 , iaspects = [] , ieffects = [] , ifeature = [ toVelocity 50 -- oily, bad grip , Applicable, Fragile ] , idesc = "A flask of oily liquid of a suspect color." , ikit = [] } flask1 = flask { irarity = [(10, 5)] , ieffects = [ NoEffect "of strength brew" , toOrganActorTurn "strengthened" (20 + d 5) , toOrganNone "regenerating" , OnSmash (Explode "strength mist") ] } flask2 = flask { ieffects = [ NoEffect "of weakness brew" , toOrganGameTurn "weakened" (20 + d 5) , OnSmash (Explode "weakness mist") ] } flask3 = flask { ieffects = [ NoEffect "of protecting balm" , toOrganActorTurn "protected" (20 + d 5) , OnSmash (Explode "protecting balm") ] } flask4 = flask { ieffects = [ NoEffect "of PhD defense questions" , toOrganGameTurn "defenseless" (20 + d 5) , OnSmash (Explode "PhD defense question") ] } flask5 = flask { irarity = [(10, 5)] , ieffects = [ NoEffect "of haste brew" , toOrganActorTurn "fast 20" (20 + d 5) , OnSmash (Explode "haste spray") ] } flask6 = flask { ieffects = [ NoEffect "of lethargy brew" , toOrganGameTurn "slow 10" (20 + d 5) , toOrganNone "regenerating" , RefillCalm 3 , OnSmash (Explode "slowness spray") ] } flask7 = flask -- sight can be reduced from Calm, drunk, etc. { irarity = [(10, 7)] , ieffects = [ NoEffect "of eye drops" , toOrganActorTurn "far-sighted" (20 + d 5) , OnSmash (Explode "blast 10") ] } flask8 = flask { irarity = [(10, 3)] , ieffects = [ NoEffect "of smelly concoction" , toOrganActorTurn "keen-smelling" (20 + d 5) , OnSmash (Explode "blast 10") ] } flask9 = flask { ieffects = [ NoEffect "of bait cocktail" , toOrganActorTurn "drunk" (5 + d 5) , OnSmash (Summon [("mobile animal", 1)] $ 1 + dl 2) , OnSmash (Explode "waste") ] } flask10 = flask { ieffects = [ NoEffect "of whiskey" , toOrganActorTurn "drunk" (20 + d 5) , Impress, Burn 2, RefillHP 4 , OnSmash (Explode "whiskey spray") ] } flask11 = flask { irarity = [(1, 20), (10, 10)] , ieffects = [ NoEffect "of regeneration brew" , toOrganNone "regenerating" , OnSmash (Explode "healing mist") ] } flask12 = flask -- but not flask of Calm depletion, since Calm reduced often { ieffects = [ NoEffect "of poison" , toOrganNone "poisoned" , OnSmash (Explode "wounding mist") ] } flask13 = flask { irarity = [(10, 5)] , ieffects = [ NoEffect "of slow resistance" , toOrganNone "slow resistant" , OnSmash (Explode "anti-slow mist") ] } flask14 = flask { irarity = [(10, 5)] , ieffects = [ NoEffect "of poison resistance" , toOrganNone "poison resistant" , OnSmash (Explode "antidote mist") ] } -- * Non-exploding consumables, not specifically designed for throwing scroll = ItemKind { isymbol = symbolScroll , iname = "scroll" , ifreq = [("useful", 100), ("any scroll", 100)] , iflavour = zipFancy stdCol ++ zipPlain darkCol -- arcane and old , icount = 1 , irarity = [(1, 15), (10, 12)] , 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 { ifreq = [("treasure", 100)] , irarity = [(5, 10), (10, 10)] -- mixed blessing, so available early , iaspects = [Unique] , ieffects = [ NoEffect "of Reckless Beacon" , CallFriend 1, Summon standardSummon (2 + d 2) ] } scroll2 = scroll { irarity = [] , ieffects = [] } scroll3 = scroll { irarity = [(1, 5), (10, 3)] , ieffects = [Ascend (-1)] } scroll4 = scroll { ieffects = [OneOf [ Teleport 5, RefillCalm 5, RefillCalm (-5) , InsertMove 5, Paralyze 10 ]] } scroll5 = scroll { irarity = [(10, 15)] , ieffects = [ Impress , OneOf [ Teleport 20, Ascend (-1), Ascend 1 , Summon standardSummon 2, CallFriend 1 , RefillCalm 5, OverfillCalm (-60) , CreateItem CGround "useful" TimerNone ] ] } scroll6 = scroll { ieffects = [Teleport 5] } scroll7 = scroll { ieffects = [Teleport 20] } scroll8 = scroll { irarity = [(10, 3)] , ieffects = [InsertMove $ 1 + d 2 + dl 2] } scroll9 = scroll -- TODO: remove Calm when server can tell if anything IDed { irarity = [(1, 15), (10, 10)] , ieffects = [ NoEffect "of scientific explanation" , Identify, OverfillCalm 3 ] } scroll10 = scroll -- TODO: firecracker only if an item really polymorphed? -- But currently server can't tell. { irarity = [(10, 10)] , ieffects = [ NoEffect "transfiguration" , PolyItem, Explode "firecracker 7" ] } scroll11 = scroll { ifreq = [("treasure", 100)] , irarity = [(6, 10), (10, 10)] , iaspects = [Unique] , ieffects = [NoEffect "of Prisoner Release", CallFriend 1] } standardSummon :: Freqs ItemKind standardSummon = [("mobile monster", 30), ("mobile animal", 70)] -- * Armor armorLeather = ItemKind { isymbol = symbolTorsoArmor , iname = "leather armor" , ifreq = [("useful", 100), ("torso armor", 1)] , iflavour = zipPlain [Brown] , icount = 1 , irarity = [(1, 9), (10, 3)] , iverbHit = "thud" , iweight = 7000 , iaspects = [ AddHurtMelee (-3) , AddArmorMelee $ 1 + d 2 + dl 2 |*| 5 , AddArmorRanged $ 1 + d 2 + dl 2 |*| 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 = [(6, 9), (10, 3)] , iweight = 12000 , iaspects = [ AddHurtMelee (-3) , AddArmorMelee $ 2 + d 2 + dl 3 |*| 5 , AddArmorRanged $ 2 + d 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 = symbolMiscArmor , iname = "leather gauntlet" , ifreq = [("useful", 100)] , iflavour = zipPlain [BrYellow] , icount = 1 , irarity = [(5, 9), (10, 9)] , iverbHit = "flap" , iweight = 100 , iaspects = [ AddHurtMelee $ (d 2 + dl 10) |*| 3 , AddArmorRanged $ d 2 |*| 5 ] , 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" , iflavour = zipPlain [BrCyan] , irarity = [(1, 9), (10, 3)] , iweight = 300 , iaspects = [ AddArmorMelee $ 1 + dl 2 |*| 5 , AddArmorRanged $ 1 + dl 2 |*| 5 ] , idesc = "Long leather gauntlet covered in overlapping steel plates." } gloveJousting = gloveFencing { iname = "Tournament Gauntlet" , iflavour = zipFancy [BrRed] , irarity = [(1, 3), (10, 3)] , iweight = 500 , iaspects = [ Unique , AddHurtMelee $ dl 4 - 6 |*| 3 , AddArmorMelee $ 2 + dl 2 |*| 5 , AddArmorRanged $ 2 + dl 2 |*| 5 ] , idesc = "Rigid, steel, jousting handgear. If only you had a lance. And a horse." } -- * Shields -- Shield doesn't protect against ranged attacks to prevent -- micromanagement: walking with shield, melee without. buckler = ItemKind { isymbol = symbolShield , iname = "buckler" , ifreq = [("useful", 100)] , iflavour = zipPlain [Blue] , icount = 1 , irarity = [(4, 6)] , iverbHit = "bash" , iweight = 2000 , iaspects = [ AddArmorMelee 40 , AddHurtMelee (-30) , Timeout $ d 3 + 3 - dl 3 |*| 2 ] , ieffects = [ Hurt (1 * d 1) -- to display xdy everywhre in Hurt , Recharging (PushActor (ThrowMod 200 50)) ] , ifeature = [ toVelocity 40 -- unwieldy to throw , 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 = [(8, 3)] , iflavour = zipPlain [Green] , iweight = 3000 , iaspects = [ AddArmorMelee 80 , AddHurtMelee (-70) , Timeout $ d 6 + 6 - dl 6 |*| 2 ] , ieffects = [Hurt (1 * d 1), Recharging (PushActor (ThrowMod 400 50))] , ifeature = [ toVelocity 30 -- unwieldy to throw , 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 = symbolEdged , iname = "dagger" , ifreq = [("useful", 100), ("starting weapon", 100)] , iflavour = zipPlain [BrCyan] , icount = 1 , irarity = [(1, 20)] , iverbHit = "stab" , iweight = 1000 , iaspects = [ AddHurtMelee $ d 3 + dl 3 |*| 3 , AddArmorMelee $ d 2 |*| 5 , AddHurtRanged (-60) ] -- as powerful as a dart , ieffects = [Hurt (6 * 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 = [] } daggerDropBestWeapon = dagger { iname = "Double Dagger" , ifreq = [("treasure", 20)] , irarity = [(1, 2), (10, 4)] -- The timeout has to be small, so that the player can count on the effect -- occuring consistently in any longer fight. Otherwise, the effect will be -- absent in some important fights, leading to the feeling of bad luck, -- but will manifest sometimes in fights where it doesn't matter, -- leading to the feeling of wasted power. -- If the effect is very powerful and so the timeout has to be significant, -- let's make it really large, for the effect to occur only once in a fight: -- as soon as the item is equipped, or just on the first strike. , iaspects = [Unique, Timeout $ d 3 + 4 - dl 3 |*| 2] , ieffects = ieffects dagger ++ [Recharging DropBestWeapon, Recharging $ RefillCalm (-3)] , idesc = "A double dagger that a focused fencer can use to catch and twist an opponent's blade occasionally." } hammer = ItemKind { isymbol = symbolHafted , iname = "war hammer" , ifreq = [("useful", 100), ("starting weapon", 100)] , iflavour = zipPlain [BrMagenta] , icount = 1 , irarity = [(5, 15)] , iverbHit = "club" , iweight = 1500 , iaspects = [ AddHurtMelee $ d 2 + dl 2 |*| 3 , AddHurtRanged (-80) ] -- as powerful as a dart , ieffects = [Hurt (8 * 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 = [] } hammerParalyze = hammer { iname = "Concussion Hammer" , ifreq = [("treasure", 20)] , irarity = [(5, 2), (10, 4)] , iaspects = [Unique, Timeout $ d 2 + 3 - dl 2 |*| 2] , ieffects = ieffects hammer ++ [Recharging $ Paralyze 5] } hammerSpark = hammer { iname = "Grand Smithhammer" , ifreq = [("treasure", 20)] , irarity = [(5, 2), (10, 4)] , iaspects = [Unique, Timeout $ d 4 + 4 - dl 4 |*| 2] , ieffects = ieffects hammer ++ [Recharging $ Explode "spark"] } sword = ItemKind { isymbol = symbolEdged , iname = "sword" , ifreq = [("useful", 100), ("starting weapon", 100)] , iflavour = zipPlain [BrBlue] , icount = 1 , irarity = [(4, 1), (5, 15)] , iverbHit = "slash" , iweight = 2000 , iaspects = [] , ieffects = [Hurt (10 * d 1)] , ifeature = [ toVelocity 5 -- 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 = [] } swordImpress = sword { iname = "Master's Sword" , ifreq = [("treasure", 20)] , irarity = [(5, 1), (10, 4)] , iaspects = [Unique, Timeout $ d 4 + 5 - dl 4 |*| 2] , ieffects = ieffects sword ++ [Recharging Impress] , idesc = "A particularly well-balance blade, lending itself to impressive shows of fencing skill." } swordNullify = sword { iname = "Gutting Sword" , ifreq = [("treasure", 20)] , irarity = [(5, 1), (10, 4)] , iaspects = [Unique, Timeout $ d 4 + 5 - dl 4 |*| 2] , ieffects = ieffects sword ++ [ Recharging $ DropItem COrgan "temporary conditions" True , Recharging $ RefillHP (-2) ] , idesc = "Cold, thin blade that pierces deeply and sends its victim into abrupt, sobering shock." } halberd = ItemKind { isymbol = symbolPolearm , iname = "war scythe" , ifreq = [("useful", 100), ("starting weapon", 1)] , iflavour = zipPlain [BrYellow] , icount = 1 , irarity = [(7, 1), (10, 10)] , iverbHit = "impale" , iweight = 3000 , iaspects = [AddArmorMelee $ 1 + dl 3 |*| 5] , ieffects = [Hurt (12 * d 1)] , ifeature = [ toVelocity 5 -- not balanced , Durable, EqpSlot EqpSlotWeapon "", Identified ] , idesc = "An improvised but deadly weapon made of a blade from a scythe attached to a long pole." , ikit = [] } halberdPushActor = halberd { iname = "Swiss Halberd" , ifreq = [("treasure", 20)] , irarity = [(7, 1), (10, 4)] , iaspects = [Unique, Timeout $ d 5 + 5 - dl 5 |*| 2] , ieffects = ieffects halberd ++ [Recharging (PushActor (ThrowMod 400 25))] , idesc = "A versatile polearm, with great reach and leverage. Foes are held at a distance." } -- * Wands wand = ItemKind { isymbol = symbolWand , 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 = [] } -- * Treasure gem = ItemKind { isymbol = symbolGem , iname = "gem" , ifreq = [("treasure", 100), ("gem", 100)] , iflavour = zipPlain $ delete BrYellow brightCol -- natural, so not fancy , icount = 1 , irarity = [] , iverbHit = "tap" , iweight = 50 , iaspects = [AddLight 1, AddSpeed (-1)] -- reflects strongly, distracts; so it glows in the dark, -- is visible on dark floor, but not too tempting to wear , ieffects = [] , ifeature = [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, 12)] } gem2 = gem { irarity = [(4, 0), (10, 14)] } gem3 = gem { irarity = [(6, 0), (10, 16)] } gem4 = gem { iname = "elixir" , iflavour = zipPlain [BrYellow] , irarity = [(1, 40), (10, 40)] , iaspects = [] , ieffects = [NoEffect "of youth", OverfillCalm 5, OverfillHP 15] , ifeature = [Identified, Applicable, Precious] -- TODO: only heal humans , 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 heals minor ailments rather well." } currency = ItemKind { isymbol = symbolGold , iname = "gold piece" , ifreq = [("treasure", 100), ("currency", 100)] , iflavour = zipPlain [BrYellow] , icount = 10 + d 20 + dl 20 , irarity = [(1, 25), (10, 10)] , iverbHit = "tap" , iweight = 31 , iaspects = [] , ieffects = [] , ifeature = [Identified, Precious] , idesc = "Reliably valuable in every civilized plane of existence." , ikit = [] } LambdaHack-0.5.0.0/GameDefinition/Content/ModeKind.hs0000644000000000000000000003276512555256425020361 0ustar0000000000000000-- | Game mode definitions. module Content.ModeKind ( cdefs ) where import qualified Data.IntMap.Strict as IM import Content.ModeKindPlayer import Game.LambdaHack.Common.ContentDef import Game.LambdaHack.Common.Dice import Game.LambdaHack.Common.Misc import Game.LambdaHack.Content.ModeKind cdefs :: ContentDef ModeKind cdefs = ContentDef { getSymbol = msymbol , getName = mname , getFreq = mfreq , validateSingle = validateSingleModeKind , validateAll = validateAllModeKind , content = [campaign, raid, skirmish, ambush, battle, battleSurvival, safari, safariSurvival, pvp, coop, defense, screensaver, boardgame] } campaign, raid, skirmish, ambush, battle, battleSurvival, safari, safariSurvival, pvp, coop, defense, screensaver, boardgame :: ModeKind campaign = ModeKind { msymbol = 'c' , mname = "campaign" , mfreq = [("campaign", 1)] , mroster = rosterCampaign , mcaves = cavesCampaign , mdesc = "Don't let wanton curiosity, greed and the creeping abstraction madness keep you down there in the darkness for too long!" } raid = ModeKind { msymbol = 'r' , mname = "raid" , mfreq = [("raid", 1)] , mroster = rosterRaid , mcaves = cavesRaid , mdesc = "An incredibly advanced typing machine worth 100 gold is buried at the other end of this maze. Be the first to claim it and fund a research team that will make typing accurate and dependable forever." } skirmish = ModeKind { msymbol = 'k' , mname = "skirmish" , mfreq = [("skirmish", 1)] , mroster = rosterSkirmish , mcaves = cavesSkirmish , mdesc = "Your type theory research teams disagreed about the premises of a relative completeness theorem and there's only one way to settle that." } ambush = ModeKind { msymbol = 'm' , mname = "ambush" , mfreq = [("ambush", 1)] , mroster = rosterAmbush , mcaves = cavesAmbush , mdesc = "Surprising, striking ideas and fast execution are what makes or breaks a creative team!" } battle = ModeKind { msymbol = 'b' , mname = "battle" , mfreq = [("battle", 1)] , mroster = rosterBattle , mcaves = cavesBattle , mdesc = "Odds are stacked against those that unleash the horrors of abstraction." } battleSurvival = ModeKind { msymbol = 'i' , mname = "battle survival" , mfreq = [("battle survival", 1)] , mroster = rosterBattleSurvival , mcaves = cavesBattle , mdesc = "Odds are stacked for those that breathe mathematics." } safari = ModeKind { msymbol = 'f' , mname = "safari" , mfreq = [("safari", 1)] , mroster = rosterSafari , 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)." } safariSurvival = ModeKind { msymbol = 'u' , mname = "safari survival" , mfreq = [("safari survival", 1)] , mroster = rosterSafariSurvival , mcaves = cavesSafari , mdesc = "In this simulation you'll discover the joys of being hunted among the most exquisite of Earth's flora and fauna, both animal and semi-intelligent." } pvp = ModeKind { msymbol = 'v' , mname = "PvP" , mfreq = [("PvP", 1)] , mroster = rosterPvP , mcaves = cavesSkirmish , mdesc = "(Not usable right now.) This is a fight to the death between two human-controlled teams." } coop = ModeKind { msymbol = 'o' , mname = "Coop" , mfreq = [("Coop", 1)] , mroster = rosterCoop , mcaves = cavesCampaign , mdesc = "(This mode is intended solely for automated testing.)" } defense = ModeKind { msymbol = 'e' , mname = "defense" , mfreq = [("defense", 1)] , mroster = rosterDefense , mcaves = cavesCampaign , mdesc = "Don't let the humans defile your abstract secrets and flee, like the vulgar, literal, base scoundrels that they are!" } screensaver = safari { mname = "safari screensaver" , mfreq = [("starting", 1)] , mroster = rosterSafari { rosterList = (head (rosterList rosterSafari)) -- changing leader by client needed, because of TFollow -- changing level by client enabled for UI {fleaderMode = LeaderAI $ AutoLeader False False} : tail (rosterList rosterSafari) } } boardgame = ModeKind { msymbol = 'g' , mname = "boardgame" , mfreq = [("boardgame", 1)] , mroster = rosterBoardgame , mcaves = cavesBoardgame , mdesc = "Small room, no exits. Who will prevail?" } rosterCampaign, rosterRaid, rosterSkirmish, rosterAmbush, rosterBattle, rosterBattleSurvival, rosterSafari, rosterSafariSurvival, rosterPvP, rosterCoop, rosterDefense, rosterBoardgame:: Roster rosterCampaign = Roster { rosterList = [ playerHero , playerMonster , playerAnimal ] , rosterEnemy = [ ("Adventurer Party", "Monster Hive") , ("Adventurer Party", "Animal Kingdom") ] , rosterAlly = [("Monster Hive", "Animal Kingdom")] } rosterRaid = Roster { rosterList = [ playerHero { fname = "White Recursive" , fhiCondPoly = hiRaid , fentryLevel = -4 , finitialActors = 1 } , playerAntiHero { fname = "Red Iterative" , fhiCondPoly = hiRaid , fentryLevel = -4 , finitialActors = 1 } , playerAnimal { fentryLevel = -4 , finitialActors = 2 } ] , rosterEnemy = [ ("White Recursive", "Animal Kingdom") , ("Red Iterative", "Animal Kingdom") ] , rosterAlly = [] } rosterSkirmish = Roster { rosterList = [ playerHero { fname = "White Haskell" , fhiCondPoly = hiDweller , fentryLevel = -3 } , playerAntiHero { fname = "Purple Agda" , fhiCondPoly = hiDweller , fentryLevel = -3 } , playerHorror ] , rosterEnemy = [ ("White Haskell", "Purple Agda") , ("White Haskell", "Horror Den") , ("Purple Agda", "Horror Den") ] , rosterAlly = [] } rosterAmbush = Roster { rosterList = [ playerSniper { fname = "Yellow Idris" , fhiCondPoly = hiDweller , fentryLevel = -5 , finitialActors = 4 } , playerAntiSniper { fname = "Blue Epigram" , fhiCondPoly = hiDweller , fentryLevel = -5 , finitialActors = 4 } , playerHorror {fentryLevel = -5} ] , rosterEnemy = [ ("Yellow Idris", "Blue Epigram") , ("Yellow Idris", "Horror Den") , ("Blue Epigram", "Horror Den") ] , rosterAlly = [] } rosterBattle = Roster { rosterList = [ playerSoldier { fhiCondPoly = hiDweller , fentryLevel = -5 , finitialActors = 5 } , playerMobileMonster { fentryLevel = -5 , finitialActors = 35 , fneverEmpty = True } , playerMobileAnimal { fentryLevel = -5 , finitialActors = 30 , fneverEmpty = True } ] , rosterEnemy = [ ("Armed Adventurer Party", "Monster Hive") , ("Armed Adventurer Party", "Animal Kingdom") ] , rosterAlly = [("Monster Hive", "Animal Kingdom")] } rosterBattleSurvival = rosterBattle { rosterList = [ playerSoldier { fhiCondPoly = hiDweller , fentryLevel = -5 , finitialActors = 5 , fleaderMode = LeaderAI $ AutoLeader True False , fhasUI = False } , playerMobileMonster { fentryLevel = -5 , finitialActors = 35 , fneverEmpty = True } , playerMobileAnimal { fentryLevel = -5 , finitialActors = 30 , fneverEmpty = True , fhasUI = True } ] } playerMonsterTourist, playerHunamConvict, playerAnimalMagnificent, playerAnimalExquisite :: Player Dice playerMonsterTourist = playerAntiMonster { fname = "Monster Tourist Office" , fcanEscape = True , fneverEmpty = True -- no spawning -- Follow-the-guide, as tourists do. , ftactic = TFollow , fentryLevel = -4 , finitialActors = 15 , fleaderMode = LeaderUI $ AutoLeader False False } playerHunamConvict = playerCivilian { fname = "Hunam Convict Pack" , fentryLevel = -4 } playerAnimalMagnificent = playerMobileAnimal { fname = "Animal Magnificent Specimen Variety" , fneverEmpty = True , fentryLevel = -7 , finitialActors = 10 , fleaderMode = -- move away from stairs LeaderAI $ AutoLeader True False } playerAnimalExquisite = playerMobileAnimal { fname = "Animal Exquisite Herds and Packs" , fneverEmpty = True , fentryLevel = -10 , finitialActors = 30 } rosterSafari = Roster { rosterList = [ playerMonsterTourist , playerHunamConvict , playerAnimalMagnificent , playerAnimalExquisite ] , rosterEnemy = [ ("Monster Tourist Office", "Hunam Convict Pack") , ( "Monster Tourist Office" , "Animal Magnificent Specimen Variety") , ( "Monster Tourist Office" , "Animal Exquisite Herds and Packs") ] , rosterAlly = [ ( "Animal Magnificent Specimen Variety" , "Animal Exquisite Herds and Packs" ) , ( "Animal Magnificent Specimen Variety" , "Hunam Convict Pack" ) , ( "Hunam Convict Pack" , "Animal Exquisite Herds and Packs" ) ] } rosterSafariSurvival = rosterSafari { rosterList = [ playerMonsterTourist { fleaderMode = LeaderAI $ AutoLeader True False , fhasUI = False } , playerHunamConvict , playerAnimalMagnificent { fleaderMode = LeaderUI $ AutoLeader False False , fhasUI = True } , playerAnimalExquisite ] } rosterPvP = Roster { rosterList = [ playerHero { fname = "Red" , fhiCondPoly = hiDweller , fentryLevel = -3 } , playerHero { fname = "Blue" , fhiCondPoly = hiDweller , fentryLevel = -3 } , playerHorror ] , rosterEnemy = [ ("Red", "Blue") , ("Red", "Horror Den") , ("Blue", "Horror Den") ] , rosterAlly = [] } rosterCoop = Roster { rosterList = [ playerAntiHero { fname = "Coral" } , playerAntiHero { fname = "Amber" , fleaderMode = LeaderNull } , playerAnimal { fhasUI = True } , playerAnimal , playerMonster , playerMonster { fname = "Leaderless Monster Hive" , fleaderMode = LeaderNull } ] , rosterEnemy = [ ("Coral", "Monster Hive") , ("Amber", "Monster Hive") ] , rosterAlly = [ ("Coral", "Amber") ] } rosterDefense = rosterCampaign { rosterList = [ playerAntiHero , playerAntiMonster , playerAnimal ] } rosterBoardgame = Roster { rosterList = [ playerHero { fname = "Blue" , fhiCondPoly = hiDweller , fentryLevel = -3 , finitialActors = 6 } , playerAntiHero { fname = "Red" , fhiCondPoly = hiDweller , fentryLevel = -3 , finitialActors = 6 } , playerHorror ] , rosterEnemy = [ ("Blue", "Red") , ("Blue", "Horror Den") , ("Red", "Horror Den") ] , rosterAlly = [] } cavesCampaign, cavesRaid, cavesSkirmish, cavesAmbush, cavesBattle, cavesSafari, cavesBoardgame :: Caves cavesCampaign = IM.fromList $ [ (-1, ("shallow random 1", Just True)) , (-2, ("caveRogue", Nothing)) , (-3, ("caveEmpty", Nothing)) ] ++ zip [-4, -5..(-9)] (repeat ("campaign random", Nothing)) ++ [(-10, ("caveNoise", Nothing))] cavesRaid = IM.fromList [(-4, ("caveRogueLit", Just True))] cavesSkirmish = IM.fromList [(-3, ("caveSkirmish", Nothing))] cavesAmbush = IM.fromList [(-5, ("caveAmbush", Nothing))] cavesBattle = IM.fromList [(-5, ("caveBattle", Nothing))] cavesSafari = IM.fromList [ (-4, ("caveSafari1", Nothing)) , (-7, ("caveSafari2", Nothing)) , (-10, ("caveSafari3", Just False)) ] cavesBoardgame = IM.fromList [(-3, ("caveBoardgame", Nothing))] LambdaHack-0.5.0.0/GameDefinition/Content/CaveKind.hs0000644000000000000000000002064212555256425020342 0ustar0000000000000000-- | Cave layouts. module Content.CaveKind ( cdefs ) where import Data.Ratio import Game.LambdaHack.Common.ContentDef import Game.LambdaHack.Common.Dice import Game.LambdaHack.Common.Misc import Game.LambdaHack.Content.CaveKind cdefs :: ContentDef CaveKind cdefs = ContentDef { getSymbol = csymbol , getName = cname , getFreq = cfreq , validateSingle = validateSingleCaveKind , validateAll = validateAllCaveKind , content = [rogue, arena, empty, noise, shallow1rogue, battle, skirmish, ambush, safari1, safari2, safari3, rogueLit, boardgame] } rogue, arena, empty, noise, shallow1rogue, battle, skirmish, ambush, safari1, safari2, safari3, rogueLit, boardgame :: CaveKind rogue = CaveKind { csymbol = 'R' , cname = "A maze of twisty passages" , cfreq = [("campaign random", 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 -- always night , cauxConnects = 1%3 , cmaxVoid = 1%6 , cminStairDist = 30 , cdoorChance = 1%2 , copenChance = 1%10 , chidden = 8 , cactorCoeff = 130 -- the maze requires time to explore , cactorFreq = [("monster", 60), ("animal", 40)] , citemNum = 10 * d 2 , citemFreq = [("useful", 50), ("treasure", 50)] , cplaceFreq = [("rogue", 100)] , cpassable = False , cdefTile = "fillerWall" , cdarkCorTile = "floorCorridorDark" , clitCorTile = "floorCorridorLit" , cfillerTile = "fillerWall" , couterFenceTile = "basic outer fence" , clegendDarkTile = "legendDark" , clegendLitTile = "legendLit" } arena = rogue { csymbol = 'A' , cname = "Underground library" , cfreq = [("campaign random", 50), ("caveArena", 1)] , cgrid = DiceXY (2 * d 2) (2 * d 2) , cminPlaceSize = DiceXY (2 * d 2 + 3) 4 , cdarkChance = d 100 - dl 50 -- Trails provide enough light for fun stealth. Light is not too deadly, -- because not many obstructions, so foes visible from far away. , cnightChance = d 50 + dl 50 , cmaxVoid = 1%4 , chidden = 1000 , cactorCoeff = 100 , cactorFreq = [("monster", 30), ("animal", 70)] , citemNum = 9 * d 2 -- few rooms , citemFreq = [("useful", 20), ("treasure", 30), ("any scroll", 50)] , cpassable = True , cdefTile = "arenaSet" , cdarkCorTile = "trailLit" -- let trails give off light , clitCorTile = "trailLit" } empty = rogue { csymbol = 'E' , cname = "Tall cavern" , cfreq = [("caveEmpty", 1)] , cgrid = DiceXY (d 2 + 1) 1 , cminPlaceSize = DiceXY 10 10 , cmaxPlaceSize = DiceXY 24 12 , cdarkChance = d 80 + dl 80 , cnightChance = 0 -- always day , cauxConnects = 1 , cmaxVoid = 1%2 , cminStairDist = 50 , chidden = 1000 , cactorCoeff = 3 , cactorFreq = [("monster", 2), ("animal", 8), ("immobile vents", 90)] -- The healing geysers on lvl 3 act like HP resets. They are needed to avoid -- cascading failure, if the particular starting conditions were -- very hard. The items are not reset, even if the 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 they don't heal over -- max HP. , citemNum = 7 * d 2 -- few rooms , cpassable = True , cdefTile = "emptySet" , cdarkCorTile = "floorArenaDark" , clitCorTile = "floorArenaLit" } noise = rogue { csymbol = 'N' , cname = "Leaky, burrowed sediment" , cfreq = [("campaign random", 20), ("caveNoise", 1)] , cgrid = DiceXY (2 + d 2) 3 , cminPlaceSize = DiceXY 12 5 , cmaxPlaceSize = DiceXY 24 12 , cdarkChance = 0 -- few rooms, so all lit -- Light is deadly, because nowhere to hide and pillars enable spawning -- very close to heroes, so deep down light should be rare. , cnightChance = dl 300 , cauxConnects = 0 , cmaxVoid = 0 , chidden = 1000 , cactorCoeff = 160 -- the maze requires time to explore , cactorFreq = [("monster", 80), ("animal", 20)] , citemNum = 12 * d 2 -- an incentive to explore the labyrinth , cpassable = True , cplaceFreq = [("noise", 100)] , cdefTile = "noiseSet" , cdarkCorTile = "floorArenaDark" , clitCorTile = "floorArenaLit" } shallow1rogue = rogue { csymbol = 'D' , cname = "Entrance to the dungeon" , cfreq = [("shallow random 1", 100)] , cdarkChance = 0 , cactorFreq = filter ((/= "monster") . fst) $ cactorFreq rogue , citemNum = 15 * d 2 -- lure them in with loot , citemFreq = filter ((/= "treasure") . fst) $ citemFreq rogue } 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 , cminPlaceSize = DiceXY 4 4 , cmaxPlaceSize = DiceXY 9 7 , cdarkChance = 0 , cnightChance = 51 -- always night , cmaxVoid = 0 , cdoorChance = 2%10 , copenChance = 9%10 , chidden = 1000 , cactorFreq = [] , citemNum = 20 * d 2 , citemFreq = [("useful", 100), ("light source", 200)] , cplaceFreq = [("battle", 50), ("rogue", 50)] , cpassable = True , cdefTile = "battleSet" , cdarkCorTile = "trailLit" -- let trails give off light , clitCorTile = "trailLit" } 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) , cminPlaceSize = DiceXY 3 3 , cmaxPlaceSize = DiceXY 7 5 , cdarkChance = 100 , cnightChance = 0 , cdoorChance = 1 , copenChance = 0 , chidden = 1000 , cactorFreq = [] , citemNum = 20 * d 2 , citemFreq = [("useful", 100)] , cplaceFreq = [("skirmish", 60), ("rogue", 40)] , cpassable = True , cdefTile = "skirmishSet" , cdarkCorTile = "floorArenaLit" , clitCorTile = "floorArenaLit" } 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) , cminPlaceSize = DiceXY 3 3 , cmaxPlaceSize = DiceXY 5 5 , cdarkChance = 0 , cnightChance = 51 -- always night , cauxConnects = 1 , cdoorChance = 1%10 , copenChance = 9%10 , chidden = 1000 , cactorFreq = [] , citemNum = 22 * d 2 , citemFreq = [("useful", 100)] , cplaceFreq = [("ambush", 100)] , cpassable = True , cdefTile = "ambushSet" , cdarkCorTile = "trailLit" -- let trails give off light , clitCorTile = "trailLit" } safari1 = ambush {cfreq = [("caveSafari1", 1)]} safari2 = battle {cfreq = [("caveSafari2", 1)]} safari3 = skirmish {cfreq = [("caveSafari3", 1)]} rogueLit = rogue { csymbol = 'S' , cname = "Typing den" , cfreq = [("caveRogueLit", 1)] , cdarkChance = 0 , cmaxVoid = 1%10 , cactorCoeff = 1000 -- deep level with no eqp, so slow spawning , cactorFreq = [("animal", 100)] , citemNum = 30 * d 2 -- just one level, hard enemies, treasure , citemFreq = [("useful", 33), ("gem", 33), ("currency", 33)] } boardgame = CaveKind { csymbol = 'B' , cname = "A boardgame" , cfreq = [("caveBoardgame", 1)] , cxsize = fst normalLevelBound + 1 , cysize = snd normalLevelBound + 1 , cgrid = DiceXY 1 1 , cminPlaceSize = DiceXY 10 10 , cmaxPlaceSize = DiceXY 10 10 , cdarkChance = 0 , cnightChance = 0 , cauxConnects = 0 , cmaxVoid = 0 , cminStairDist = 0 , cdoorChance = 0 , copenChance = 0 , chidden = 0 , cactorCoeff = 0 , cactorFreq = [] , citemNum = 0 , citemFreq = [] , cplaceFreq = [("boardgame", 1)] , cpassable = False , cdefTile = "fillerWall" , cdarkCorTile = "floorCorridorDark" , clitCorTile = "floorCorridorLit" , cfillerTile = "fillerWall" , couterFenceTile = "basic outer fence" , clegendDarkTile = "legendDark" , clegendLitTile = "legendLit" } LambdaHack-0.5.0.0/GameDefinition/Content/ItemKindActor.hs0000644000000000000000000004170012555256425021351 0ustar0000000000000000-- | Actor (or rather actor body trunk) definitions. module Content.ItemKindActor ( actors ) where import qualified Data.EnumMap.Strict as EM import Game.LambdaHack.Common.Ability import Game.LambdaHack.Common.Color import Game.LambdaHack.Common.Flavour import Game.LambdaHack.Common.Misc import Game.LambdaHack.Content.ItemKind actors :: [ItemKind] actors = [warrior, warrior2, warrior3, warrior4, warrior5, soldier, sniper, civilian, civilian2, civilian3, civilian4, civilian5, eye, fastEye, nose, elbow, torsor, goldenJackal, griffonVulture, skunk, armadillo, gilaMonster, rattlesnake, komodoDragon, hyena, alligator, rhinoceros, beeSwarm, hornetSwarm, thornbush, geyserBoiling, geyserArsenic, geyserSulfur] warrior, warrior2, warrior3, warrior4, warrior5, soldier, sniper, civilian, civilian2, civilian3, civilian4, civilian5, eye, fastEye, nose, elbow, torsor, goldenJackal, griffonVulture, skunk, armadillo, gilaMonster, rattlesnake, komodoDragon, hyena, alligator, rhinoceros, beeSwarm, hornetSwarm, thornbush, geyserBoiling, geyserArsenic, geyserSulfur :: ItemKind -- * Hunams warrior = ItemKind { isymbol = '@' , iname = "warrior" -- modified if in hero faction , ifreq = [("hero", 100), ("civilian", 100), ("mobile", 1)] , iflavour = zipPlain [BrBlack] -- modified if in hero faction , icount = 1 , irarity = [(1, 5)] , iverbHit = "thud" , iweight = 80000 , iaspects = [ AddMaxHP 60 -- partially from clothes and assumed first aid , AddMaxCalm 60, AddSpeed 20 , AddSkills $ EM.fromList [(AbProject, 2), (AbApply, 1)] ] , ieffects = [] , ifeature = [Durable, Identified] , idesc = "" , ikit = [ ("fist", COrgan), ("foot", COrgan), ("eye 5", COrgan) , ("sapient brain", COrgan) ] } warrior2 = warrior { iname = "adventurer" } warrior3 = warrior { iname = "blacksmith" } warrior4 = warrior { iname = "forester" } warrior5 = warrior { iname = "scientist" } soldier = warrior { iname = "soldier" , ifreq = [("soldier", 100), ("mobile", 1)] , ikit = ikit warrior ++ [("starting weapon", CEqp)] } sniper = warrior { iname = "sniper" , ifreq = [("sniper", 100), ("mobile", 1)] , ikit = ikit warrior ++ [ ("ring of opportunity sniper", CEqp) , ("any arrow", CSha), ("any arrow", CInv) , ("any arrow", CInv), ("any arrow", CInv) , ("flask", CInv), ("light source", CSha) , ("light source", CInv), ("light source", CInv) ] } civilian = warrior { iname = "clerk" , ifreq = [("civilian", 100), ("mobile", 1)] } civilian2 = civilian { iname = "hairdresser" } civilian3 = civilian { iname = "lawyer" } civilian4 = civilian { iname = "peddler" } civilian5 = civilian { iname = "tax collector" } -- * Monsters eye = ItemKind { isymbol = 'e' , iname = "reducible eye" , ifreq = [("monster", 100), ("horror", 100), ("mobile monster", 100)] , iflavour = zipFancy [BrRed] , icount = 1 , irarity = [(1, 10), (10, 6)] , iverbHit = "thud" , iweight = 80000 , iaspects = [ AddMaxHP 16, AddMaxCalm 60, AddSpeed 20 , AddSkills $ EM.fromList [(AbProject, 2), (AbApply, 1)] ] , 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) , ("sapient brain", COrgan) ] } fastEye = ItemKind { isymbol = 'j' , iname = "injective jaw" , ifreq = [("monster", 100), ("horror", 100), ("mobile monster", 100)] , iflavour = zipFancy [BrBlue] , icount = 1 , irarity = [(5, 5), (10, 5)] , iverbHit = "thud" , iweight = 80000 , iaspects = [ AddMaxHP 5, AddMaxCalm 60, AddSpeed 30 ] , 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), ("vision 4", COrgan) , ("sapient brain", COrgan) ] } nose = ItemKind -- depends solely on smell { isymbol = 'n' , iname = "point-free nose" , ifreq = [("monster", 100), ("horror", 100), ("mobile monster", 100)] , iflavour = zipFancy [BrGreen] , icount = 1 , irarity = [(1, 5), (4, 2), (10, 5)] , iverbHit = "thud" , iweight = 80000 , iaspects = [ AddMaxHP 30, AddMaxCalm 30, AddSpeed 18 , AddSkills $ EM.fromList [(AbProject, -1)] ] , 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), ("nostril", COrgan) , ("sapient brain", COrgan) ] } elbow = ItemKind { isymbol = 'e' , iname = "commutative elbow" , ifreq = [("monster", 100), ("horror", 100), ("mobile monster", 100)] , iflavour = zipFancy [BrMagenta] , icount = 1 , irarity = [(7, 1), (10, 5)] , iverbHit = "thud" , iweight = 80000 , iaspects = [ AddMaxHP 8, AddMaxCalm 90, AddSpeed 21 , AddSkills $ EM.fromList [(AbProject, 2), (AbApply, 1), (AbMelee, -1)] ] , 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) , ("vision 14", COrgan) , ("any arrow", CSha), ("any arrow", CInv) , ("any arrow", CInv), ("any arrow", CInv) , ("sapient brain", COrgan) ] } torsor = ItemKind { isymbol = '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 , iaspects = [ Unique, AddMaxHP 300, AddMaxCalm 100, AddSpeed 10 , AddSkills $ EM.fromList [(AbProject, 2), (AbApply, 1), (AbTrigger, -1)] ] -- can't switch levels, a miniboss , ieffects = [] , ifeature = [Durable, Identified] , 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 = [ ("right torsion", COrgan), ("left torsion", COrgan) , ("pupil", COrgan) , ("gem", CInv), ("gem", CInv), ("gem", CInv), ("gem", CInv) , ("sapient brain", COrgan) ] } -- "ground x" --- for immovable monster that can only tele or prob travel -- pullback -- skeletal -- * Animals -- They need rather strong melee, because they don't use items. -- Unless/until they level up. goldenJackal = ItemKind -- basically a much smaller and slower hyena { isymbol = 'j' , iname = "golden jackal" , ifreq = [("animal", 100), ("horror", 100), ("mobile animal", 100), ("scavenger", 50)] , iflavour = zipPlain [BrYellow] , icount = 1 , irarity = [(1, 5)] , iverbHit = "thud" , iweight = 13000 , iaspects = [ AddMaxHP 12, AddMaxCalm 60, AddSpeed 22 ] , ieffects = [] , ifeature = [Durable, Identified] , idesc = "" , ikit = [ ("small jaw", COrgan), ("eye 5", COrgan), ("nostril", COrgan) , ("animal brain", COrgan) ] } griffonVulture = ItemKind { isymbol = 'v' , iname = "griffon vulture" , ifreq = [("animal", 100), ("horror", 100), ("mobile animal", 100), ("scavenger", 30)] , iflavour = zipPlain [BrYellow] , icount = 1 , irarity = [(1, 5)] , iverbHit = "thud" , iweight = 13000 , iaspects = [ AddMaxHP 12, AddMaxCalm 60, AddSpeed 20 , AddSkills $ EM.singleton AbAlter (-1) ] , ieffects = [] , ifeature = [Durable, Identified] , idesc = "" , ikit = [ ("screeching beak", COrgan) -- in reality it grunts and hisses , ("small claw", COrgan), ("eye 6", COrgan) , ("animal brain", COrgan) ] } skunk = ItemKind { isymbol = 's' , iname = "hog-nosed skunk" , ifreq = [("animal", 100), ("horror", 100), ("mobile animal", 100)] , iflavour = zipPlain [White] , icount = 1 , irarity = [(1, 5), (10, 3)] , iverbHit = "thud" , iweight = 4000 , iaspects = [ AddMaxHP 10, AddMaxCalm 30, AddSpeed 20 , AddSkills $ EM.singleton AbAlter (-1) ] , ieffects = [] , ifeature = [Durable, Identified] , idesc = "" , ikit = [ ("scent gland", COrgan) , ("small claw", COrgan), ("snout", COrgan) , ("nostril", COrgan), ("eye 2", COrgan) , ("animal brain", COrgan) ] } armadillo = ItemKind { isymbol = 'a' , iname = "giant armadillo" , ifreq = [("animal", 100), ("horror", 100), ("mobile animal", 100)] , iflavour = zipPlain [Brown] , icount = 1 , irarity = [(1, 5)] , iverbHit = "thud" , iweight = 80000 , iaspects = [ AddMaxHP 20, AddMaxCalm 30, AddSpeed 17 , AddSkills $ EM.singleton AbAlter (-1) ] , ieffects = [] , ifeature = [Durable, Identified] , idesc = "" , ikit = [ ("claw", COrgan), ("snout", COrgan), ("armored skin", COrgan) , ("nostril", COrgan), ("eye 2", COrgan) , ("animal brain", COrgan) ] } gilaMonster = ItemKind { isymbol = 'g' , iname = "Gila monster" , ifreq = [("animal", 100), ("horror", 100), ("mobile animal", 100)] , iflavour = zipPlain [Magenta] , icount = 1 , irarity = [(2, 5), (10, 3)] , iverbHit = "thud" , iweight = 80000 , iaspects = [ AddMaxHP 12, AddMaxCalm 60, AddSpeed 15 , AddSkills $ EM.singleton AbAlter (-1) ] , ieffects = [] , ifeature = [Durable, Identified] , idesc = "" , ikit = [ ("venom tooth", COrgan), ("small claw", COrgan) , ("eye 2", COrgan), ("nostril", COrgan) , ("animal brain", COrgan) ] } rattlesnake = ItemKind { isymbol = 's' , iname = "rattlesnake" , ifreq = [("animal", 100), ("horror", 100), ("mobile animal", 100)] , iflavour = zipPlain [Brown] , icount = 1 , irarity = [(4, 1), (10, 7)] , iverbHit = "thud" , iweight = 80000 , iaspects = [ AddMaxHP 25, AddMaxCalm 60, AddSpeed 15 , AddSkills $ EM.singleton AbAlter (-1) ] , ieffects = [] , ifeature = [Durable, Identified] , idesc = "" , ikit = [ ("venom fang", COrgan) , ("eye 3", COrgan), ("nostril", COrgan) , ("animal brain", COrgan) ] } komodoDragon = ItemKind -- bad hearing; regeneration makes it very powerful { isymbol = 'k' , iname = "Komodo dragon" , ifreq = [("animal", 100), ("horror", 100), ("mobile animal", 100)] , iflavour = zipPlain [Blue] , icount = 1 , irarity = [(7, 0), (10, 10)] , iverbHit = "thud" , iweight = 80000 , iaspects = [ AddMaxHP 41, AddMaxCalm 60, AddSpeed 16 ] , ieffects = [] , ifeature = [Durable, Identified] , idesc = "" , ikit = [ ("large tail", COrgan), ("jaw", COrgan), ("claw", COrgan) , ("speed gland 4", COrgan), ("armored skin", COrgan) , ("eye 2", COrgan), ("nostril", COrgan) , ("animal brain", COrgan) ] } hyena = ItemKind { isymbol = 'h' , iname = "spotted hyena" , ifreq = [("animal", 100), ("horror", 100), ("mobile animal", 100), ("scavenger", 20)] , iflavour = zipPlain [BrYellow] , icount = 1 , irarity = [(4, 1), (10, 8)] , iverbHit = "thud" , iweight = 60000 , iaspects = [ AddMaxHP 20, AddMaxCalm 60, AddSpeed 30 ] , ieffects = [] , ifeature = [Durable, Identified] , idesc = "" , ikit = [ ("jaw", COrgan), ("eye 5", COrgan), ("nostril", COrgan) , ("animal brain", COrgan) ] } alligator = ItemKind { isymbol = 'a' , iname = "alligator" , ifreq = [("animal", 100), ("horror", 100), ("mobile animal", 100)] , iflavour = zipPlain [Blue] , icount = 1 , irarity = [(6, 1), (10, 9)] , iverbHit = "thud" , iweight = 80000 , iaspects = [ AddMaxHP 41, AddMaxCalm 60, AddSpeed 15 ] , ieffects = [] , ifeature = [Durable, Identified] , idesc = "" , ikit = [ ("large jaw", COrgan), ("large tail", COrgan) , ("small claw", COrgan) , ("armored skin", COrgan), ("eye 5", COrgan) , ("animal brain", COrgan) ] } rhinoceros = ItemKind { isymbol = 'R' , iname = "The Maddened Rhinoceros" , ifreq = [("animal", 100), ("mobile", 1)] , iflavour = zipPlain [Brown] , icount = 1 , irarity = [(2, 0), (3, 1000000), (4, 0)] -- unique , iverbHit = "thud" , iweight = 80000 , iaspects = [ Unique, AddMaxHP 90, AddMaxCalm 60, AddSpeed 25 , AddSkills $ EM.singleton AbTrigger (-1) ] -- can't switch levels, a miniboss , ieffects = [] , ifeature = [Durable, Identified] , idesc = "The last of its kind. Blind with rage. Charges at deadly speed." , ikit = [ ("armored skin", COrgan), ("eye 2", COrgan) , ("horn", COrgan), ("snout", COrgan) , ("animal brain", COrgan) ] } -- * Non-animal animals beeSwarm = ItemKind { isymbol = 'b' , iname = "bee swarm" , ifreq = [("animal", 100), ("horror", 100)] , iflavour = zipPlain [Brown] , icount = 1 , irarity = [(1, 2), (10, 4)] , iverbHit = "thud" , iweight = 1000 , iaspects = [ AddMaxHP 8, AddMaxCalm 60, AddSpeed 30 , AddSkills $ EM.singleton AbAlter (-1) ] -- armor in sting , ieffects = [] , ifeature = [Durable, Identified] , idesc = "" , ikit = [ ("bee sting", COrgan), ("vision 4", COrgan) , ("insect mortality", COrgan), ("animal brain", COrgan) ] } hornetSwarm = ItemKind { isymbol = 'h' , iname = "hornet swarm" , ifreq = [("animal", 100), ("horror", 100), ("mobile animal", 100)] , iflavour = zipPlain [Magenta] , icount = 1 , irarity = [(5, 1), (10, 8)] , iverbHit = "thud" , iweight = 1000 , iaspects = [ AddMaxHP 8, AddMaxCalm 60, AddSpeed 30 , AddSkills $ EM.singleton AbAlter (-1) , AddArmorMelee 80, AddArmorRanged 80 ] , ieffects = [] , ifeature = [Durable, Identified] , idesc = "" , ikit = [ ("sting", COrgan), ("vision 4", COrgan) , ("insect mortality", COrgan), ("animal brain", COrgan) ] } thornbush = ItemKind { isymbol = 't' , iname = "thornbush" , ifreq = [("animal", 50), ("immobile vents", 100)] , iflavour = zipPlain [Brown] , icount = 1 , irarity = [(1, 3)] , iverbHit = "thud" , iweight = 80000 , iaspects = [ AddMaxHP 20, AddMaxCalm 999, AddSpeed 20 , AddSkills $ EM.fromList (zip [AbWait, AbMelee] [1, 1..]) ] , ieffects = [] , ifeature = [Durable, Identified] , idesc = "" , ikit = [("thorn", COrgan), ("armored skin", COrgan)] } geyserBoiling = ItemKind { isymbol = 'g' , iname = "geyser" , ifreq = [("animal", 50), ("immobile vents", 50)] , iflavour = zipPlain [Blue] , icount = 1 , irarity = [(5, 2)] , iverbHit = "thud" , iweight = 80000 , iaspects = [ AddMaxHP 10, AddMaxCalm 999, AddSpeed 10 , AddSkills $ EM.fromList (zip [AbWait, AbMelee] [1, 1..]) , AddArmorMelee 80, AddArmorRanged 80 ] , ieffects = [] , ifeature = [Durable, Identified] , idesc = "" , ikit = [("boiling vent", COrgan), ("boiling fissure", COrgan)] } geyserArsenic = ItemKind { isymbol = 'g' , iname = "arsenic geyser" , ifreq = [("animal", 50), ("immobile vents", 100)] , iflavour = zipPlain [Cyan] , icount = 1 , irarity = [(5, 2)] , iverbHit = "thud" , iweight = 80000 , iaspects = [ AddMaxHP 30, AddMaxCalm 999, AddSpeed 20, AddLight 3 , AddSkills $ EM.fromList (zip [AbWait, AbMelee] [1, 1..]) ] , ieffects = [] , ifeature = [Durable, Identified] , idesc = "" , ikit = [("arsenic vent", COrgan), ("arsenic fissure", COrgan)] } geyserSulfur = ItemKind { isymbol = 'g' , iname = "sulfur geyser" , ifreq = [("animal", 50), ("immobile vents", 300)] , iflavour = zipPlain [BrYellow] -- exception, animal with bright color , icount = 1 , irarity = [(5, 2)] , iverbHit = "thud" , iweight = 80000 , iaspects = [ AddMaxHP 30, AddMaxCalm 999, AddSpeed 20, AddLight 3 , AddSkills $ EM.fromList (zip [AbWait, AbMelee] [1, 1..]) ] , ieffects = [] , ifeature = [Durable, Identified] -- TODO: only heal humans , idesc = "" , ikit = [("sulfur vent", COrgan), ("sulfur fissure", COrgan)] } LambdaHack-0.5.0.0/GameDefinition/Content/RuleKind.hs0000644000000000000000000000550412555256425020373 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} -- | Game rules and assorted game setup data. module Content.RuleKind ( cdefs ) where import Language.Haskell.TH.Syntax import System.FilePath -- Cabal import qualified Paths_LambdaHack as Self (getDataFileName, version) import Game.LambdaHack.Common.ContentDef import Game.LambdaHack.Common.Vector import Game.LambdaHack.Content.RuleKind cdefs :: ContentDef RuleKind cdefs = ContentDef { getSymbol = rsymbol , getName = rname , getFreq = rfreq , validateSingle = validateSingleRuleKind , validateAll = validateAllRuleKind , content = [standard] } standard :: RuleKind standard = RuleKind { rsymbol = 's' , rname = "standard LambdaHack ruleset" , rfreq = [("standard", 100)] -- Check whether one position is accessible from another. -- Precondition: the two positions are next to each other -- 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 -- The strings containing the default configuration file -- included from config.ui.default. , rcfgUIName = "config.ui" , rcfgUIDefault = $(do let path = "GameDefinition" "config.ui" <.> "default" qAddDependentFile path x <- qRunIO (readFile path) lift x) -- ASCII art for the Main Menu. Only pure 7-bit ASCII characters are -- allowed. The picture should be exactly 24 rows by 80 columns, -- plus an extra frame (of any characters) that is ignored. -- For a different screen size, the picture is centered and the outermost -- rows and columns cloned. When displayed in the Main Menu screen, -- it's overwritten with the game version string and keybinding strings. -- The game version string begins and ends with a space and is placed -- in the very bottom right corner. The keybindings overwrite places -- marked with 25 left curly brace signs '{' in a row. The sign is forbidden -- everywhere else. A specific number of such places with 25 left braces -- are required, at most one per row, and all are overwritten -- with text that is flushed left and padded with spaces. -- The Main Menu is displayed dull white on black. -- TODO: Show highlighted keybinding in inverse video or bright white on grey -- background. The spaces that pad keybindings are not highlighted. , rmainMenuArt = $(do let path = "GameDefinition/MainMenu.ascii" qAddDependentFile path x <- qRunIO (readFile path) lift x) , rfirstDeathEnds = False , rfovMode = Digital , rwriteSaveClips = 500 , rleadLevelClips = 100 , rscoresFile = "scores" , rsavePrefix = "save" , rnearby = 20 } LambdaHack-0.5.0.0/GameDefinition/Content/PlaceKind.hs0000644000000000000000000001347612555256425020517 0ustar0000000000000000-- | Room, hall and passage definitions. 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 , validateSingle = validateSinglePlaceKind , validateAll = validateAllPlaceKind , content = [rect, ruin, collapsed, collapsed2, collapsed3, collapsed4, pillar, pillar2, pillar3, pillar4, colonnade, colonnade2, colonnade3, colonnade4, colonnade5, colonnade6, lampPost, lampPost2, lampPost3, lampPost4, treeShade, treeShade2, treeShade3, boardgame] } rect, ruin, collapsed, collapsed2, collapsed3, collapsed4, pillar, pillar2, pillar3, pillar4, colonnade, colonnade2, colonnade3, colonnade4, colonnade5, colonnade6, lampPost, lampPost2, lampPost3, lampPost4, treeShade, treeShade2, treeShade3, boardgame :: PlaceKind rect = PlaceKind -- Valid for any nonempty area, hence low frequency. { psymbol = 'r' , pname = "room" , pfreq = [("rogue", 100), ("ambush", 8), ("noise", 80)] , prarity = [(1, 10), (10, 8)] , pcover = CStretch , pfence = FNone , ptopLeft = [ "--" , "|." ] , poverride = [] } ruin = PlaceKind { psymbol = 'R' , pname = "ruin" , pfreq = [("ambush", 17), ("battle", 100), ("noise", 40)] , prarity = [(1, 10), (10, 20)] , pcover = CStretch , pfence = FNone , ptopLeft = [ "--" , "|X" ] , poverride = [] } collapsed = PlaceKind { psymbol = 'c' , pname = "collapsed cavern" , pfreq = [("noise", 1)] , prarity = [(1, 10), (10, 10)] , 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), ("noise", 50)] , prarity = [(1, 10), (10, 10)] , pcover = CStretch , pfence = FNone -- Larger rooms require support pillars. , ptopLeft = [ "-----" , "|...." , "|.O.." , "|...." , "|...." ] , poverride = [] } pillar2 = pillar { ptopLeft = [ "-----" , "|O..." , "|...." , "|...." , "|...." ] } pillar3 = pillar { prarity = [(1, 2), (10, 2)] , ptopLeft = [ "-----" , "|O..." , "|..O." , "|.O.." , "|...." ] } pillar4 = pillar { prarity = [(10, 10)] , ptopLeft = [ "-----" , "|&.O." , "|...." , "|O..." , "|...." ] } colonnade = PlaceKind { psymbol = 'c' , pname = "colonnade" , pfreq = [("rogue", 70), ("noise", 2000)] , prarity = [(1, 10), (10, 10)] , pcover = CAlternate , pfence = FFloor , ptopLeft = [ "O." , ".O" ] , poverride = [] } colonnade2 = colonnade { prarity = [(1, 4), (10, 4)] , ptopLeft = [ "O." , ".." ] } colonnade3 = colonnade { prarity = [(1, 2), (10, 2)] , pfence = FGround , ptopLeft = [ ".." , ".O" ] } colonnade4 = colonnade { ptopLeft = [ "O.." , ".O." , "..O" ] } colonnade5 = colonnade { prarity = [(1, 4), (10, 4)] , ptopLeft = [ "O.." , "..O" ] } colonnade6 = colonnade { ptopLeft = [ "O." , ".." , ".O" ] } lampPost = PlaceKind { psymbol = 'l' , pname = "lamp post" , pfreq = [("ambush", 30), ("battle", 10)] , prarity = [(1, 10), (10, 10)] , 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, 10), (10, 10)] , 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" ] } boardgame = PlaceKind { psymbol = 'b' , pname = "boardgame" , pfreq = [("boardgame", 1)] , prarity = [(1, 1)] , pcover = CVerbatim , pfence = FNone , ptopLeft = [ "----------" , "|.b.b.b.b|" , "|b.b.b.b.|" , "|.b.b.b.b|" , "|b.b.b.b.|" , "|.b.b.b.b|" , "|b.b.b.b.|" , "|.b.b.b.b|" , "|b.b.b.b.|" , "----------" ] , poverride = [('b', "trailChessLit")] } LambdaHack-0.5.0.0/GameDefinition/Content/TileKind.hs0000644000000000000000000002433312555256425020362 0ustar0000000000000000-- | Terrain tile definitions. module Content.TileKind ( cdefs ) where import Control.Arrow (first) import Data.Maybe import qualified Data.Text as T import Game.LambdaHack.Common.Color import Game.LambdaHack.Common.ContentDef import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.Msg import qualified Game.LambdaHack.Content.ItemKind as IK import Game.LambdaHack.Content.TileKind cdefs :: ContentDef TileKind cdefs = ContentDef { getSymbol = tsymbol , getName = tname , getFreq = tfreq , validateSingle = validateSingleTileKind , validateAll = validateAllTileKind , 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 wall = TileKind { tsymbol = ' ' , tname = "bedrock" , tfreq = [("fillerWall", 1), ("legendLit", 100), ("legendDark", 100)] , tcolor = defBG , tcolor2 = defBG , 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). -- 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. } hardRock = TileKind { tsymbol = ' ' , tname = "impenetrable bedrock" , tfreq = [("basic outer fence", 1)] , tcolor = BrWhite , tcolor2 = BrWhite , tfeature = [Dark, Impenetrable] } pillar = TileKind { tsymbol = 'O' , tname = "rock" , tfreq = [ ("cachable", 70) , ("legendLit", 100), ("legendDark", 100) , ("noiseSet", 100), ("skirmishSet", 5) , ("battleSet", 250) ] , tcolor = BrWhite , tcolor2 = defFG , tfeature = [] } pillarCache = TileKind { tsymbol = '&' , tname = "cache" , tfreq = [ ("cachable", 30) , ("legendLit", 100), ("legendDark", 100) ] , tcolor = BrWhite , tcolor2 = defFG , tfeature = [ Cause $ IK.CreateItem CGround "useful" IK.TimerNone , ChangeTo "cachable" ] } lampPost = TileKind { tsymbol = 'O' , tname = "lamp post" , tfreq = [("lampPostOver_O", 90)] , tcolor = BrYellow , tcolor2 = Brown , tfeature = [] } burningBush = TileKind { tsymbol = 'O' , tname = "burning bush" , tfreq = [("lampPostOver_O", 10), ("ambushSet", 3), ("battleSet", 2)] , tcolor = BrRed , tcolor2 = Red , tfeature = [] } bush = TileKind { tsymbol = 'O' , tname = "bush" , tfreq = [("ambushSet", 100) ] , tcolor = Green , tcolor2 = BrBlack , tfeature = [Dark] } tree = TileKind { tsymbol = 'O' , tname = "tree" , tfreq = [("skirmishSet", 14), ("battleSet", 20), ("treeShadeOver_O", 1)] , tcolor = BrGreen , tcolor2 = Green , tfeature = [] } wallV = TileKind { tsymbol = '|' , tname = "granite wall" , tfreq = [("legendLit", 100)] , tcolor = BrWhite , tcolor2 = defFG , tfeature = [HideAs "suspect vertical wall Lit"] } wallSuspectV = TileKind { tsymbol = '|' , tname = "moldy wall" , tfreq = [("suspect vertical wall Lit", 1)] , tcolor = BrWhite , tcolor2 = defFG , tfeature = [Suspect, RevealAs "vertical closed door Lit"] } doorClosedV = TileKind { tsymbol = '+' , tname = "closed door" , tfreq = [("vertical closed door Lit", 1)] , tcolor = Brown , tcolor2 = BrBlack , tfeature = [ OpenTo "vertical open door Lit" , HideAs "suspect vertical wall Lit" ] } doorOpenV = TileKind { tsymbol = '-' , tname = "open door" , tfreq = [("vertical open door Lit", 1)] , tcolor = Brown , tcolor2 = BrBlack , tfeature = [ Walkable, Clear, 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"] } wallSuspectH = TileKind { tsymbol = '-' , tname = "scratched wall" , tfreq = [("suspect horizontal wall Lit", 1)] , tcolor = BrWhite , tcolor2 = defFG , tfeature = [Suspect, RevealAs "horizontal closed door Lit"] } doorClosedH = TileKind { tsymbol = '+' , tname = "closed door" , tfreq = [("horizontal closed door Lit", 1)] , tcolor = Brown , tcolor2 = BrBlack , tfeature = [ OpenTo "horizontal open door Lit" , HideAs "suspect horizontal wall Lit" ] } doorOpenH = TileKind { tsymbol = '|' , tname = "open door" , tfreq = [("horizontal open door Lit", 1)] , tcolor = Brown , tcolor2 = BrBlack , tfeature = [ Walkable, Clear, NoItem, NoActor , CloseTo "horizontal closed door Lit" ] } stairsUpLit = TileKind { tsymbol = '<' , tname = "staircase up" , tfreq = [("legendLit", 100)] , tcolor = BrWhite , tcolor2 = defFG , tfeature = [Walkable, Clear, NoItem, NoActor, Cause $ IK.Ascend 1] } stairsLit = TileKind { tsymbol = '>' , tname = "staircase" , tfreq = [("legendLit", 100)] , tcolor = BrCyan , tcolor2 = Cyan -- TODO , tfeature = [ Walkable, Clear, NoItem, NoActor , Cause $ IK.Ascend 1 , Cause $ IK.Ascend (-1) ] } stairsDownLit = TileKind { tsymbol = '>' , tname = "staircase down" , tfreq = [("legendLit", 100)] , tcolor = BrWhite , tcolor2 = defFG , tfeature = [Walkable, Clear, NoItem, NoActor, Cause $ IK.Ascend (-1)] } escapeUpLit = TileKind { tsymbol = '<' , tname = "exit hatch up" , tfreq = [("legendLit", 100)] , tcolor = BrYellow , tcolor2 = BrYellow , tfeature = [Walkable, Clear, NoItem, NoActor, Cause $ IK.Escape 1] } escapeDownLit = TileKind { tsymbol = '>' , tname = "exit trapdoor down" , tfreq = [("legendLit", 100)] , tcolor = BrYellow , tcolor2 = BrYellow , tfeature = [Walkable, Clear, NoItem, NoActor, Cause $ IK.Escape (-1)] } unknown = TileKind { tsymbol = ' ' , tname = "unknown space" , tfreq = [("unknown space", 1)] , tcolor = defFG , tcolor2 = defFG , tfeature = [Dark] } floorCorridorLit = TileKind { tsymbol = '#' , tname = "corridor" , tfreq = [("floorCorridorLit", 1)] , tcolor = BrWhite , tcolor2 = defFG , tfeature = [Walkable, Clear] } floorArenaLit = floorCorridorLit { tsymbol = '.' , tname = "stone floor" , tfreq = [ ("floorArenaLit", 1) , ("arenaSet", 1), ("emptySet", 1), ("noiseSet", 50) , ("battleSet", 1000), ("skirmishSet", 100) , ("ambushSet", 1000) ] } floorActorLit = floorArenaLit { tfreq = [] , tfeature = OftenActor : tfeature floorArenaLit } floorItemLit = floorArenaLit { tfreq = [] , tfeature = OftenItem : tfeature floorArenaLit } floorActorItemLit = floorItemLit { tfreq = [("legendLit", 100)] -- no OftenItem in legendDark , tfeature = OftenActor : tfeature floorItemLit } floorArenaShade = floorActorLit { tname = "stone floor" -- TODO: "shaded ground" , tfreq = [("treeShadeOver_s", 1)] , tcolor2 = BrBlack , tfeature = Dark : tfeature floorActorLit -- no OftenItem } floorRedLit = floorArenaLit { tname = "brick pavement" , tfreq = [("trailLit", 30), ("trailChessLit", 30)] , tcolor = BrRed , tcolor2 = Red , tfeature = Trail : tfeature floorArenaLit } floorBlueLit = floorRedLit { tname = "cobblestone path" , tfreq = [("trailLit", 100), ("trailChessLit", 70)] , tcolor = BrBlue , tcolor2 = Blue } floorGreenLit = floorRedLit { tname = "mossy stone path" , tfreq = [("trailLit", 100)] , tcolor = BrGreen , tcolor2 = Green } floorBrownLit = floorRedLit { tname = "rotting mahogany deck" , tfreq = [("trailLit", 10)] , tcolor = BrMagenta , tcolor2 = Magenta } makeDark :: TileKind -> TileKind makeDark k = let darkText :: GroupName TileKind -> GroupName TileKind darkText t = maybe t (toGroupName . (<> "Dark")) $ T.stripSuffix "Lit" $ tshow 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 -- items not common in the dark darkFeat feat = Just feat in k { tfreq = darkFrequency , tfeature = Dark : mapMaybe darkFeat (tfeature k) } makeDarkColor :: TileKind -> TileKind makeDarkColor k = (makeDark k) {tcolor2 = BrBlack} LambdaHack-0.5.0.0/GameDefinition/Content/ItemKindTemporary.hs0000644000000000000000000000562012555256425022264 0ustar0000000000000000-- | Temporary aspect pseudo-item definitions. module Content.ItemKindTemporary ( temporaries ) where import Data.Text (Text) import Game.LambdaHack.Common.Color import Game.LambdaHack.Common.Dice import Game.LambdaHack.Common.Flavour import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.Msg import Game.LambdaHack.Content.ItemKind temporaries :: [ItemKind] temporaries = [tmpStrengthened, tmpWeakened, tmpProtected, tmpVulnerable, tmpFast20, tmpSlow10, tmpFarSighted, tmpKeenSmelling, tmpDrunk, tmpRegenerating, tmpPoisoned, tmpSlow10Resistant, tmpPoisonResistant] tmpStrengthened, tmpWeakened, tmpProtected, tmpVulnerable, tmpFast20, tmpSlow10, tmpFarSighted, tmpKeenSmelling, tmpDrunk, tmpRegenerating, tmpPoisoned, tmpSlow10Resistant, tmpPoisonResistant :: ItemKind -- The @name@ is be used in item description, so it should be an adjective -- describing the temporary set of aspects. tmpAs :: Text -> [Aspect Dice] -> ItemKind tmpAs name aspects = ItemKind { isymbol = '+' , iname = name , ifreq = [(toGroupName name, 1), ("temporary conditions", 1)] , iflavour = zipPlain [BrWhite] , icount = 1 , irarity = [(1, 1)] , iverbHit = "affect" , iweight = 0 , iaspects = [Periodic, Timeout 0] -- activates and vanishes soon, -- depending on initial timer setting ++ aspects , ieffects = let tmp = Temporary $ "be no longer" <+> name in [Recharging tmp, OnSmash tmp] , ifeature = [Identified] , idesc = "" , ikit = [] } tmpStrengthened = tmpAs "strengthened" [AddHurtMelee 20] tmpWeakened = tmpAs "weakened" [AddHurtMelee (-20)] tmpProtected = tmpAs "protected" [ AddArmorMelee 30 , AddArmorRanged 30 ] tmpVulnerable = tmpAs "defenseless" [ AddArmorMelee (-30) , AddArmorRanged (-30) ] tmpFast20 = tmpAs "fast 20" [AddSpeed 20] tmpSlow10 = tmpAs "slow 10" [AddSpeed (-10)] tmpFarSighted = tmpAs "far-sighted" [AddSight 5] tmpKeenSmelling = tmpAs "keen-smelling" [AddSmell 2] tmpDrunk = tmpAs "drunk" [ AddHurtMelee 30 -- fury , AddArmorMelee (-20) , AddArmorRanged (-20) , AddSight (-7) ] tmpRegenerating = let tmp = tmpAs "regenerating" [] in tmp { icount = 7 + d 5 , ieffects = Recharging (RefillHP 1) : ieffects tmp } tmpPoisoned = let tmp = tmpAs "poisoned" [] in tmp { icount = 7 + d 5 , ieffects = Recharging (RefillHP (-1)) : ieffects tmp } tmpSlow10Resistant = let tmp = tmpAs "slow resistant" [] in tmp { icount = 7 + d 5 , ieffects = Recharging (DropItem COrgan "slow 10" True) : ieffects tmp } tmpPoisonResistant = let tmp = tmpAs "poison resistant" [] in tmp { icount = 7 + d 5 , ieffects = Recharging (DropItem COrgan "poisoned" True) : ieffects tmp } LambdaHack-0.5.0.0/GameDefinition/Content/ModeKindPlayer.hs0000644000000000000000000001111612555256425021521 0ustar0000000000000000-- | Basic players definitions. module Content.ModeKindPlayer ( playerHero, playerSoldier, playerSniper , playerAntiHero, playerAntiSniper, playerCivilian , playerMonster, playerMobileMonster, playerAntiMonster , playerAnimal, playerMobileAnimal , playerHorror , hiHero, hiDweller, hiRaid ) where import Data.List import Game.LambdaHack.Common.Ability import Game.LambdaHack.Common.Dice import Game.LambdaHack.Common.Misc import Game.LambdaHack.Content.ModeKind playerHero, playerSoldier, playerSniper, playerAntiHero, playerAntiSniper, playerCivilian, playerMonster, playerMobileMonster, playerAntiMonster, playerAnimal, playerMobileAnimal, playerHorror :: Player Dice playerHero = Player { fname = "Adventurer Party" , fgroup = "hero" , fskillsOther = meleeAdjacent , fcanEscape = True , fneverEmpty = True , fhiCondPoly = hiHero , fhasNumbers = True , fhasGender = True , ftactic = TExplore , fentryLevel = -1 , finitialActors = 3 , fleaderMode = LeaderUI $ AutoLeader False False , fhasUI = True } playerSoldier = playerHero { fname = "Armed Adventurer Party" , fgroup = "soldier" } playerSniper = playerHero { fname = "Sniper Adventurer Party" , fgroup = "sniper" } playerAntiHero = playerHero { fleaderMode = LeaderAI $ AutoLeader True False , fhasUI = False } playerAntiSniper = playerSniper { fleaderMode = LeaderAI $ AutoLeader True False , fhasUI = False } playerCivilian = Player { fname = "Civilian Crowd" , fgroup = "civilian" , fskillsOther = zeroSkills -- not coordinated by any leadership , fcanEscape = False , fneverEmpty = True , fhiCondPoly = hiDweller , fhasNumbers = False , fhasGender = True , ftactic = TPatrol , fentryLevel = -1 , finitialActors = d 2 + 1 , fleaderMode = LeaderNull -- unorganized , fhasUI = False } playerMonster = Player { fname = "Monster Hive" , fgroup = "monster" , fskillsOther = zeroSkills , fcanEscape = False , fneverEmpty = False , fhiCondPoly = hiDweller , fhasNumbers = False , fhasGender = False , ftactic = TExplore , fentryLevel = -4 , finitialActors = 4 -- one of these most probably not nose, so will explore , fleaderMode = -- No point changing leader on level, since all move and they -- don't follow the leader. LeaderAI $ AutoLeader True True , fhasUI = False } playerMobileMonster = playerMonster playerAntiMonster = playerMonster { fhasUI = True , fleaderMode = LeaderUI $ AutoLeader True True } playerAnimal = Player { fname = "Animal Kingdom" , fgroup = "animal" , fskillsOther = zeroSkills , fcanEscape = False , fneverEmpty = False , fhiCondPoly = hiDweller , fhasNumbers = False , fhasGender = False , ftactic = TRoam -- can't pick up, so no point exploring , fentryLevel = -1 -- fun from the start to avoid empty initial level , finitialActors = 1 + d 2 , fleaderMode = LeaderNull , fhasUI = False } playerMobileAnimal = playerAnimal { fgroup = "mobile animal" } -- | A special player, 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. -- Actors that can be summoned should have "horror" in their @ifreq@ set. playerHorror = Player { fname = "Horror Den" , fgroup = "horror" , fskillsOther = zeroSkills , fcanEscape = False , fneverEmpty = False , fhiCondPoly = [] , fhasNumbers = False , fhasGender = False , ftactic = TPatrol -- disoriented , fentryLevel = -3 , finitialActors = 0 , fleaderMode = LeaderNull , fhasUI = False } victoryOutcomes :: [Outcome] victoryOutcomes = [Conquer, Escape] hiHero, hiDweller, hiRaid :: HiCondPoly -- Heroes rejoice in loot. hiHero = [ ( [(HiLoot, 1)] , [minBound..maxBound] ) , ( [(HiConst, 1000), (HiLoss, -100)] , victoryOutcomes ) ] -- Spawners or skirmishers get no points from loot, but try to kill -- all opponents fast or at least hold up for long. hiDweller = [ ( [(HiConst, 1000)] -- no loot , victoryOutcomes ) , ( [(HiConst, 1000), (HiLoss, -10)] , victoryOutcomes ) , ( [(HiBlitz, -100)] , victoryOutcomes ) , ( [(HiSurvival, 100)] , [minBound..maxBound] \\ victoryOutcomes ) ] hiRaid = [ ( [(HiLoot, 1)] , [minBound..maxBound] ) , ( [(HiConst, 100)] , victoryOutcomes ) ] LambdaHack-0.5.0.0/GameDefinition/Client/0000755000000000000000000000000012555256425016122 5ustar0000000000000000LambdaHack-0.5.0.0/GameDefinition/Client/UI/0000755000000000000000000000000012555256425016437 5ustar0000000000000000LambdaHack-0.5.0.0/GameDefinition/Client/UI/Content/0000755000000000000000000000000012555256425020051 5ustar0000000000000000LambdaHack-0.5.0.0/GameDefinition/Client/UI/Content/KeyKind.hs0000644000000000000000000002267612555256425021760 0ustar0000000000000000-- | The default game key-command mapping to be used for UI. Can be overridden -- 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 Game.LambdaHack.Common.Misc import qualified Game.LambdaHack.Content.ItemKind as IK import qualified Game.LambdaHack.Content.TileKind as TK 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-r", ([CmdMenu], GameRestart "raid")) , ("CTRL-k", ([CmdMenu], GameRestart "skirmish")) , ("CTRL-m", ([CmdMenu], GameRestart "ambush")) , ("CTRL-b", ([CmdMenu], GameRestart "battle")) , ("CTRL-c", ([CmdMenu], GameRestart "campaign")) , ("CTRL-i", ([CmdDebug], GameRestart "battle survival")) , ("CTRL-f", ([CmdDebug], GameRestart "safari")) , ("CTRL-u", ([CmdDebug], GameRestart "safari survival")) , ("CTRL-e", ([CmdDebug], GameRestart "defense")) , ("CTRL-g", ([CmdDebug], GameRestart "boardgame")) , ("CTRL-d", ([CmdMenu], GameDifficultyCycle)) -- Movement and terrain alteration , ("less", ([CmdMove, CmdMinimal], TriggerTile [ TriggerFeature { verb = "ascend" , object = "a level" , feature = TK.Cause (IK.Ascend 1) } , TriggerFeature { verb = "escape" , object = "dungeon" , feature = TK.Cause (IK.Escape 1) } ])) , ("CTRL-less", ([CmdMove], TriggerTile [ TriggerFeature { verb = "ascend" , object = "10 levels" , feature = TK.Cause (IK.Ascend 10) } ])) , ("greater", ([CmdMove, CmdMinimal], TriggerTile [ TriggerFeature { verb = "descend" , object = "a level" , feature = TK.Cause (IK.Ascend (-1)) } , TriggerFeature { verb = "escape" , object = "dungeon" , feature = TK.Cause (IK.Escape (-1)) } ])) , ("CTRL-greater", ([CmdMove], TriggerTile [ TriggerFeature { verb = "descend" , object = "10 levels" , feature = TK.Cause (IK.Ascend (-10)) } ])) , ("semicolon", ( [CmdMove] , Macro "go to crosshair for 100 steps" ["CTRL-semicolon", "CTRL-period", "V"] )) , ("colon", ( [CmdMove] , Macro "run selected to crosshair for 100 steps" ["CTRL-colon", "CTRL-period", "V"] )) , ("x", ( [CmdMove] , Macro "explore the closest unknown spot" [ "CTRL-question" -- no semicolon , "CTRL-period", "V" ] )) , ("X", ( [CmdMove] , Macro "autoexplore 100 times" ["'", "CTRL-question", "CTRL-period", "'", "V"] )) , ("CTRL-X", ( [CmdMove] , Macro "autoexplore 25 times" ["'", "CTRL-question", "CTRL-period", "'", "CTRL-V"] )) , ("R", ([CmdMove], Macro "rest (wait 100 times)" ["KP_Begin", "V"])) , ("CTRL-R", ([CmdMove], Macro "rest (wait 25 times)" ["KP_Begin", "CTRL-V"])) , ("c", ([CmdMove, CmdMinimal], AlterDir [ AlterFeature { verb = "close" , object = "door" , feature = TK.CloseTo "vertical closed door Lit" } , AlterFeature { verb = "close" , object = "door" , feature = TK.CloseTo "horizontal closed door Lit" } , AlterFeature { verb = "close" , object = "door" , feature = TK.CloseTo "vertical closed door Dark" } , AlterFeature { verb = "close" , object = "door" , feature = TK.CloseTo "horizontal closed door Dark" } ])) -- Item use , ("E", ([CmdItem, CmdMinimal], DescribeItem $ MStore CEqp)) , ("P", ([CmdItem], DescribeItem $ MStore CInv)) , ("S", ([CmdItem], DescribeItem $ MStore CSha)) , ("A", ([CmdItem], DescribeItem MOwned)) , ("G", ([CmdItem], DescribeItem $ MStore CGround)) , ("@", ([CmdItem], DescribeItem $ MStore COrgan)) , ("exclam", ([CmdItem], DescribeItem MStats)) , ("g", ([CmdItem, CmdMinimal], MoveItem [CGround] CEqp (Just "get") "items" True)) , ("d", ([CmdItem], MoveItem [CEqp, CInv, CSha] CGround Nothing "items" False)) , ("e", ([CmdItem], MoveItem [CGround, CInv, CSha] CEqp Nothing "items" False)) , ("p", ([CmdItem], MoveItem [CGround, CEqp, CSha] CInv Nothing "items into inventory" False)) , ("s", ([CmdItem], MoveItem [CGround, CInv, CEqp] CSha Nothing "and share items" False)) , ("a", ([CmdItem, CmdMinimal], Apply [ ApplyItem { verb = "apply" , object = "consumable" , 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 = "projectile" , symbol = ' ' }])) , ("t", ([CmdItem], Project [ApplyItem { verb = "throw" , object = "missile" , symbol = '|' }])) -- , ("z", ([CmdItem], Project [ApplyItem { verb = "zap" -- , object = "wand" -- , symbol = '/' }])) -- Targeting , ("KP_Multiply", ([CmdTgt], TgtEnemy)) , ("backslash", ([CmdTgt], Macro "" ["KP_Multiply"])) , ("KP_Divide", ([CmdTgt], TgtFloor)) , ("bar", ([CmdTgt], Macro "" ["KP_Divide"])) , ("plus", ([CmdTgt, CmdMinimal], EpsIncr True)) , ("minus", ([CmdTgt], EpsIncr False)) , ("CTRL-question", ([CmdTgt], CursorUnknown)) , ("CTRL-I", ([CmdTgt], CursorItem)) , ("CTRL-braceleft", ([CmdTgt], CursorStair True)) , ("CTRL-braceright", ([CmdTgt], CursorStair False)) , ("BackSpace", ([CmdTgt], TgtClear)) -- Automation , ("equal", ([CmdAuto], SelectActor)) , ("underscore", ([CmdAuto], SelectNone)) , ("v", ([CmdAuto], Repeat 1)) , ("V", ([CmdAuto], Repeat 100)) , ("CTRL-v", ([CmdAuto], Repeat 1000)) , ("CTRL-V", ([CmdAuto], Repeat 25)) , ("apostrophe", ([CmdAuto], Record)) , ("CTRL-T", ([CmdAuto], Tactic)) , ("CTRL-A", ([CmdAuto], Automate)) -- Assorted , ("question", ([CmdMeta], Help)) , ("D", ([CmdMeta, CmdMinimal], History)) , ("T", ([CmdMeta, CmdMinimal], MarkSuspect)) , ("Z", ([CmdMeta], MarkVision)) , ("C", ([CmdMeta], MarkSmell)) , ("Tab", ([CmdMeta], MemberCycle)) , ("ISO_Left_Tab", ([CmdMeta, CmdMinimal], MemberBack)) , ("space", ([CmdMeta], Clear)) , ("Escape", ([CmdMeta, CmdMinimal], Cancel)) , ("Return", ([CmdMeta, CmdTgt], Accept)) -- Mouse , ("LeftButtonPress", ([CmdMouse], macroLeftButtonPress)) , ("SHIFT-LeftButtonPress", ([CmdMouse], macroShiftLeftButtonPress)) , ("MiddleButtonPress", ([CmdMouse], CursorPointerEnemy)) , ("SHIFT-MiddleButtonPress", ([CmdMouse], CursorPointerFloor)) , ("CTRL-MiddleButtonPress", ([CmdInternal], Macro "" ["SHIFT-MiddleButtonPress"])) , ("RightButtonPress", ([CmdMouse], TgtPointerEnemy)) -- Debug and others not to display in help screens , ("CTRL-S", ([CmdDebug], GameSave)) , ("CTRL-semicolon", ([CmdInternal], MoveOnceToCursor)) , ("CTRL-colon", ([CmdInternal], RunOnceToCursor)) , ("CTRL-period", ([CmdInternal], ContinueToCursor)) , ("CTRL-comma", ([CmdInternal], RunOnceAhead)) , ("CTRL-LeftButtonPress", ([CmdInternal], Macro "" ["SHIFT-LeftButtonPress"])) , ("CTRL-MiddleButtonPress", ([CmdInternal], Macro "" ["SHIFT-MiddleButtonPress"])) , ("ALT-space", ([CmdInternal], StopIfTgtMode)) , ("ALT-minus", ([CmdInternal], SelectWithPointer)) ] } LambdaHack-0.5.0.0/test/0000755000000000000000000000000012555256425013001 5ustar0000000000000000LambdaHack-0.5.0.0/test/test.hs0000644000000000000000000000106412555256425014315 0ustar0000000000000000import TieKnot main :: IO () main = tieKnot $ tail $ words "dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame 2 --noDelay --noAnim --maxFps 100000 --frontendNull --benchmark --stopAfter 6 --automateAll --keepAutomated --gameMode campaign --setDungeonRng 42 --setMainRng 42" -- tieKnot $ tail $ words "dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame 2 --noDelay --noAnim --maxFps 100000 --frontendNull --benchmark --stopAfter 6 --automateAll --keepAutomated --gameMode battle --setDungeonRng 42 --setMainRng 42"