LambdaHack-0.8.3.0/0000755000000000000000000000000013315545734012027 5ustar0000000000000000LambdaHack-0.8.3.0/COPYLEFT0000644000000000000000000001614013315545734013201 0ustar0000000000000000Format: https://www.debian.org/doc/packaging-manuals/copyright-format/1.0/ Upstream-Name: LambdaHack Upstream-Contact: Mikolaj Konarski Source: https://hackage.haskell.org/package/LambdaHack Files: * Copyright: 2008-2011 Andres Loeh 2010-2018 Mikolaj Konarski and others (see git history) License: BSD-3-clause Files: GameDefinition/fonts/*.fon Copyright: 1997-2016 Leon Marrick 1997-2016 Sheldon Simms III 1997-2016 Nick McConnell 2016-2018 Mikolaj Konarski License: GPL-2 Files: GameDefinition/fonts/Fix15Mono-Bold.woff Copyright: 2012-2015 The Mozilla Foundation and Telefonica S.A 2016-2018 Mikolaj Konarski License: OFL-1.1 Files: debian/* Copyright: held by the contributors mentioned in debian/changelog License: BSD-3-clause License: BSD-3-clause Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. . THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. License: GPL-2 This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License, version 2, as published by the Free Software Foundation . This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. . You should have received a copy of the GNU General Public License along with this package; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA . On Debian systems, the full text of the GNU General Public License version 2 can be found in the file `/usr/share/common-licenses/GPL-2'. License: OFL-1.1 SIL OPEN FONT LICENSE Version 1.1 - 26 February 2007 . PREAMBLE The goals of the Open Font License (OFL) are to stimulate worldwide development of collaborative font projects, to support the font creation efforts of academic and linguistic communities, and to provide a free and open framework in which fonts may be shared and improved in partnership with others. . The OFL allows the licensed fonts to be used, studied, modified and redistributed freely as long as they are not sold by themselves. The fonts, including any derivative works, can be bundled, embedded, redistributed and/or sold with any software provided that any reserved names are not used by derivative works. The fonts and derivatives, however, cannot be released under any other type of license. The requirement for fonts to remain under this license does not apply to any document created using the fonts or their derivatives. . DEFINITIONS Font Software refers to the set of files released by the Copyright Holder(s) under this license and clearly marked as such. This may include source files, build scripts and documentation. . Reserved Font Name refers to any names specified as such after the copyright statement(s). . Original Version refers to the collection of Font Software components as distributed by the Copyright Holder(s). . Modified Version refers to any derivative made by adding to, deleting, or substituting in part or in whole any of the components of the Original Version, by changing formats or by porting the Font Software to a new environment. . Author refers to any designer, engineer, programmer, technical writer or other person who contributed to the Font Software. . PERMISSION & CONDITIONS Permission is hereby granted, free of charge, to any person obtaining a copy of the Font Software, to use, study, copy, merge, embed, modify, redistribute, and sell modified and unmodified copies of the Font Software, subject to the following conditions: . 1) Neither the Font Software nor any of its individual components, in Original or Modified Versions, may be sold by itself. . 2) Original or Modified Versions of the Font Software may be bundled, redistributed and/or sold with any software, provided that each copy contains the above copyright notice and this license. These can be included either as stand-alone text files, human-readable headers or in the appropriate machine-readable metadata fields within text or binary files as long as those fields can be easily viewed by the user. . 3) No Modified Version of the Font Software may use the Reserved Font Name(s) unless explicit written permission is granted by the corresponding Copyright Holder. This restriction only applies to the primary font name as presented to the users. . 4) The name(s) of the Copyright Holder(s) or the Author(s) of the Font Software shall not be used to promote, endorse or advertise any Modified Version, except to acknowledge the contribution(s) of the Copyright Holder(s) and the Author(s) or with their explicit written permission. . 5) The Font Software, modified or unmodified, in part or in whole, must be distributed entirely under this license, and must not be distributed under any other license. The requirement for fonts to remain under this license does not apply to any document created using the Font Software. . TERMINATION This license becomes null and void if any of the above conditions are not met. . DISCLAIMER THE FONT SOFTWARE IS PROVIDED AS IS, WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO ANY WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT OF COPYRIGHT, PATENT, TRADEMARK, OR OTHER RIGHT. IN NO EVENT SHALL THE COPYRIGHT HOLDER BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, INCLUDING ANY GENERAL, SPECIAL, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL DAMAGES, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF THE USE OR INABILITY TO USE THE FONT SOFTWARE OR FROM OTHER DEALINGS IN THE FONT SOFTWARE. LambdaHack-0.8.3.0/CREDITS0000644000000000000000000000271613315545734013055 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 Veronika Romashkina @Peritract Pablo Reszczynski Fonts 16x16x.fon, 8x8x.fon and 8x8xb.fon are are taken from https://github.com/angband/angband, copyrighted by Leon Marrick, Sheldon Simms III and Nick McConnell and released by them under GNU GPL version 2. Any further modifications by authors of LambdaHack are also released under GNU GPL version 2. The licence file is at GameDefinition/fonts/LICENSE.16x16x in the source code tree. Font Fix15Mono-Bold.woff is a modified version of https://github.com/mozilla/Fira/blob/master/ttf/FiraMono-Bold.ttf that is copyright 2012-2015, The Mozilla Foundation and Telefonica S.A. The modified font is released under the SIL Open Font License, as seen in GameDefinition/fonts/LICENSE.Fix15Mono-Bold in the source code tree. Modifications were performed with font editor FontForge and are as follows: * straighten and enlarge #, enlarge %, &, ', +, \,, -, :, ;, O, _, ` * centre a few other glyphs * create a small 0x22c5 * shrink 0xb7 a bit * extend all fonts by 150% and 150% (the extension resulted in an artifact in letter 'n', which was gleefully kept, and many other artifacts and distortions that should be fixed at some point) * set width of space, nbsp and # glyphs to 1170 (this is a hack to make DOM create square table cells) LambdaHack-0.8.3.0/LambdaHack.cabal0000644000000000000000000005105713315545734014772 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 -- | | +----- minor or non-breaking API additions -- | | | +--- code changes with no API change version: 0.8.3.0 synopsis: A game engine library for tactical squad ASCII roguelike dungeon crawlers description: LambdaHack is a Haskell game engine library for ASCII roguelike games of arbitrary theme, size and complexity, with optional tactical squad combat. It's packaged together with a sample dungeon crawler in fantasy setting that can be tried out in the browser at . (It runs fastest on Chrome. Keyboard commands and savefiles are supported only on recent enough versions of browsers. Mouse should work everywhere.) . Please see the changelog file for recent improvements and the issue tracker for short-term plans. Long term goals include multiplayer tactical squad combat, in-game content creation, auto-balancing and persistent content modification based on player behaviour. Contributions are welcome. . 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: https://lambdahack.github.io bug-reports: http://github.com/LambdaHack/LambdaHack/issues license: BSD3 license-file: COPYLEFT tested-with: GHC==8.0.2, GHC==8.2.2, GHC==8.4.3 data-files: GameDefinition/config.ui.default, GameDefinition/fonts/16x16x.fon, GameDefinition/fonts/8x8xb.fon, GameDefinition/fonts/8x8x.fon, GameDefinition/fonts/LICENSE.16x16x, GameDefinition/fonts/Fix15Mono-Bold.woff, GameDefinition/fonts/LICENSE.Fix15Mono-Bold, GameDefinition/InGameHelp.txt, README.md, CHANGELOG.md, LICENSE, COPYLEFT, CREDITS extra-source-files: GameDefinition/MainMenu.ascii, GameDefinition/PLAYING.md, 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 gtk description: switch to the GTK frontend default: False manual: True flag sdl description: switch to the SDL2 frontend default: False manual: True flag jsaddle description: switch to the JSaddle frontend (may be bit-rotted) 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 internal functions and types, etc.) default: True manual: True library exposed-modules: Game.LambdaHack.Atomic Game.LambdaHack.Atomic.CmdAtomic Game.LambdaHack.Atomic.HandleAtomicWrite Game.LambdaHack.Atomic.MonadStateWrite Game.LambdaHack.Atomic.PosAtomicRead Game.LambdaHack.Client Game.LambdaHack.Client.AI Game.LambdaHack.Client.AI.ConditionM Game.LambdaHack.Client.AI.HandleAbilityM Game.LambdaHack.Client.AI.PickActorM Game.LambdaHack.Client.AI.PickTargetM Game.LambdaHack.Client.AI.Strategy Game.LambdaHack.Client.Bfs Game.LambdaHack.Client.BfsM Game.LambdaHack.Client.ClientOptions Game.LambdaHack.Client.CommonM Game.LambdaHack.Client.HandleAtomicM Game.LambdaHack.Client.HandleResponseM Game.LambdaHack.Client.LoopM Game.LambdaHack.Client.MonadClient Game.LambdaHack.Client.Preferences Game.LambdaHack.Client.Request Game.LambdaHack.Client.Response Game.LambdaHack.Client.State Game.LambdaHack.Client.UI Game.LambdaHack.Client.UI.ActorUI Game.LambdaHack.Client.UI.Animation Game.LambdaHack.Client.UI.Content.KeyKind Game.LambdaHack.Client.UI.DrawM Game.LambdaHack.Client.UI.DisplayAtomicM Game.LambdaHack.Client.UI.EffectDescription Game.LambdaHack.Client.UI.Frame Game.LambdaHack.Client.UI.FrameM Game.LambdaHack.Client.UI.Frontend Game.LambdaHack.Client.UI.Frontend.Chosen Game.LambdaHack.Client.UI.Frontend.Common Game.LambdaHack.Client.UI.Frontend.Teletype Game.LambdaHack.Client.UI.HandleHelperM Game.LambdaHack.Client.UI.HandleHumanGlobalM Game.LambdaHack.Client.UI.HandleHumanLocalM Game.LambdaHack.Client.UI.HandleHumanM Game.LambdaHack.Client.UI.HumanCmd Game.LambdaHack.Client.UI.InventoryM Game.LambdaHack.Client.UI.ItemDescription Game.LambdaHack.Client.UI.ItemSlot Game.LambdaHack.Client.UI.Key Game.LambdaHack.Client.UI.KeyBindings Game.LambdaHack.Client.UI.MonadClientUI Game.LambdaHack.Client.UI.Msg Game.LambdaHack.Client.UI.MsgM Game.LambdaHack.Client.UI.Overlay Game.LambdaHack.Client.UI.RunM Game.LambdaHack.Client.UI.SessionUI Game.LambdaHack.Client.UI.Slideshow Game.LambdaHack.Client.UI.SlideshowM Game.LambdaHack.Client.UI.UIOptions Game.LambdaHack.Common.Ability Game.LambdaHack.Common.Actor Game.LambdaHack.Common.ActorState Game.LambdaHack.Common.Color Game.LambdaHack.Common.ContentData Game.LambdaHack.Common.Dice 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.ItemAspect Game.LambdaHack.Common.Kind Game.LambdaHack.Common.Level Game.LambdaHack.Common.Misc Game.LambdaHack.Common.MonadStateRead Game.LambdaHack.Common.Perception Game.LambdaHack.Common.PointArray Game.LambdaHack.Common.Point Game.LambdaHack.Common.Prelude Game.LambdaHack.Common.Random Game.LambdaHack.Common.ReqFailure Game.LambdaHack.Common.RingBuffer Game.LambdaHack.Common.Save Game.LambdaHack.Common.State Game.LambdaHack.Common.Thread Game.LambdaHack.Common.Tile Game.LambdaHack.Common.Time Game.LambdaHack.Common.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.Server Game.LambdaHack.Server.BroadcastAtomic Game.LambdaHack.Server.Commandline Game.LambdaHack.Server.CommonM Game.LambdaHack.Server.DebugM Game.LambdaHack.Server.DungeonGen Game.LambdaHack.Server.DungeonGen.Area Game.LambdaHack.Server.DungeonGen.AreaRnd Game.LambdaHack.Server.DungeonGen.Cave Game.LambdaHack.Server.DungeonGen.Place Game.LambdaHack.Server.EndM Game.LambdaHack.Server.Fov Game.LambdaHack.Server.FovDigital Game.LambdaHack.Server.HandleAtomicM Game.LambdaHack.Server.HandleEffectM Game.LambdaHack.Server.HandleRequestM Game.LambdaHack.Server.ItemRev Game.LambdaHack.Server.ItemM Game.LambdaHack.Server.LoopM Game.LambdaHack.Server.MonadServer Game.LambdaHack.Server.PeriodicM Game.LambdaHack.Server.ProtocolM Game.LambdaHack.Server.ServerOptions Game.LambdaHack.Server.StartM Game.LambdaHack.Server.State other-modules: Paths_LambdaHack build-depends: assert-failure >= 0.1.2 && < 0.2, async >= 2, base >= 4.9 && < 99, base-compat >= 0.8.0, binary >= 0.8, bytestring >= 0.9.2 , containers >= 0.5.3.0, deepseq >= 1.3, directory >= 1.1.0.1, enummapset >= 0.5.2.2, filepath >= 1.2.0.1, ghc-prim, hashable >= 1.1.2.5, hsini >= 0.2, keys >= 3, miniutter >= 0.4.5.0, optparse-applicative >= 0.13, pretty-show >= 1.6, random >= 1.1, stm >= 2.4, time >= 1.4, text >= 0.11.2.3, transformers >= 0.4, unordered-containers >= 0.2.3, vector >= 0.11, vector-binary-instances >= 0.2.3.1 default-language: Haskell2010 default-extensions: MonoLocalBinds, ScopedTypeVariables, OverloadedStrings BangPatterns, RecordWildCards, NamedFieldPuns, MultiWayIf, LambdaCase, StrictData, CPP other-extensions: TemplateHaskell, MultiParamTypeClasses, RankNTypes, TypeFamilies, FlexibleContexts, FlexibleInstances, DeriveFunctor, FunctionalDependencies, GeneralizedNewtypeDeriving, TupleSections, DeriveFoldable, DeriveTraversable, ExistentialQuantification, GADTs, StandaloneDeriving, DataKinds, KindSignatures, DeriveGeneric ghc-options: -Wall -Wcompat -Worphans -Wincomplete-uni-patterns -Wincomplete-record-updates -Wimplicit-prelude -Wmissing-home-modules -Widentities -Wredundant-constraints ghc-options: -Wall-missed-specialisations ghc-options: -fno-ignore-asserts -fexpose-all-unfoldings -fspecialise-aggressively -fsimpl-tick-factor=200 if impl(ghcjs) || flag(jsaddle) { exposed-modules: Game.LambdaHack.Client.UI.Frontend.Dom build-depends: ghcjs-dom >= 0.9.1.1 cpp-options: -DUSE_BROWSER } else { if flag(vty) { exposed-modules: Game.LambdaHack.Client.UI.Frontend.Vty build-depends: vty >= 5 cpp-options: -DUSE_VTY } else { if flag(curses) { exposed-modules: Game.LambdaHack.Client.UI.Frontend.Curses build-depends: hscurses >= 1.4.1 cpp-options: -DUSE_CURSES } else { if flag(gtk) { exposed-modules: Game.LambdaHack.Client.UI.Frontend.Gtk build-depends: gtk3 >= 0.12.1 cpp-options: -DUSE_GTK } else { exposed-modules: Game.LambdaHack.Client.UI.Frontend.Sdl build-depends: sdl2 >= 2, sdl2-ttf >= 2 cpp-options: -DUSE_SDL } } } } if impl(ghcjs) { exposed-modules: Game.LambdaHack.Common.JSFile cpp-options: -DUSE_JSFILE } else { exposed-modules: Game.LambdaHack.Common.HSFile build-depends: zlib >= 0.5.3.1 } if flag(with_expensive_assertions) cpp-options: -DWITH_EXPENSIVE_ASSERTIONS if flag(release) cpp-options: -DEXPOSE_INTERNAL executable LambdaHack hs-source-dirs: GameDefinition main-is: Main.hs other-modules: Client.UI.Content.KeyKind, Content.CaveKind, Content.ItemKind, Content.ItemKindEmbed, Content.ItemKindActor, Content.ItemKindOrgan, Content.ItemKindBlast, Content.ItemKindTemporary, Content.ModeKind, Content.ModeKindPlayer, Content.PlaceKind, Content.RuleKind, Content.TileKind, Implementation.MonadClientImplementation, Implementation.MonadServerImplementation, Implementation.TieKnot, Paths_LambdaHack build-depends: LambdaHack, template-haskell >= 2.6, assert-failure >= 0.1.2 && < 0.2, async >= 2, base >= 4.9 && < 99, base-compat >= 0.8.0, binary >= 0.8, bytestring >= 0.9.2 , containers >= 0.5.3.0, deepseq >= 1.3, directory >= 1.1.0.1, enummapset >= 0.5.2.2, filepath >= 1.2.0.1, ghc-prim, hashable >= 1.1.2.5, hsini >= 0.2, keys >= 3, miniutter >= 0.4.5.0, optparse-applicative >= 0.13, pretty-show >= 1.6, random >= 1.1, stm >= 2.4, text >= 0.11.2.3, time >= 1.4, transformers >= 0.4, unordered-containers >= 0.2.3, vector >= 0.11, vector-binary-instances >= 0.2.3.1 default-language: Haskell2010 default-extensions: MonoLocalBinds, ScopedTypeVariables, OverloadedStrings BangPatterns, RecordWildCards, NamedFieldPuns, MultiWayIf, LambdaCase, StrictData, CPP other-extensions: TemplateHaskell ghc-options: -Wall -Wcompat -Worphans -Wincomplete-uni-patterns -Wincomplete-record-updates -Wimplicit-prelude -Wmissing-home-modules -Widentities -Wredundant-constraints ghc-options: -Wall-missed-specialisations ghc-options: -fno-ignore-asserts -fexpose-all-unfoldings -fspecialise-aggressively ghc-options: -threaded -rtsopts -- Minimize median lag at the cost of occasional bigger GC lag, -- which fortunately sometimes fits into idle time between turns): ghc-options: -with-rtsopts=-A99m if impl(ghcjs) { -- This is the largest GHCJS_BUSY_YIELD value that does not cause dropped frames -- on my machine with default --maxFps. cpp-options: -DGHCJS_BUSY_YIELD=50 cpp-options: -DUSE_JSFILE } else { build-depends: zlib >= 0.5.3.1 } test-suite test type: exitcode-stdio-1.0 hs-source-dirs: GameDefinition, test main-is: test.hs other-modules: Client.UI.Content.KeyKind, Content.CaveKind, Content.ItemKind, Content.ItemKindEmbed, Content.ItemKindActor, Content.ItemKindOrgan, Content.ItemKindBlast, Content.ItemKindTemporary, Content.ModeKind, Content.ModeKindPlayer, Content.PlaceKind, Content.RuleKind, Content.TileKind, Implementation.MonadClientImplementation, Implementation.MonadServerImplementation, Implementation.TieKnot, Paths_LambdaHack build-depends: LambdaHack, template-haskell >= 2.6, assert-failure >= 0.1.2 && < 0.2, async >= 2, base >= 4.9 && < 99, base-compat >= 0.8.0, binary >= 0.8, bytestring >= 0.9.2 , containers >= 0.5.3.0, deepseq >= 1.3, directory >= 1.1.0.1, enummapset >= 0.5.2.2, filepath >= 1.2.0.1, ghc-prim, hashable >= 1.1.2.5, hsini >= 0.2, keys >= 3, miniutter >= 0.4.5.0, optparse-applicative >= 0.13, pretty-show >= 1.6, random >= 1.1, stm >= 2.4, text >= 0.11.2.3, time >= 1.4, transformers >= 0.4, unordered-containers >= 0.2.3, vector >= 0.11, vector-binary-instances >= 0.2.3.1 default-language: Haskell2010 default-extensions: MonoLocalBinds, ScopedTypeVariables, OverloadedStrings BangPatterns, RecordWildCards, NamedFieldPuns, MultiWayIf, LambdaCase, StrictData, CPP other-extensions: TemplateHaskell ghc-options: -Wall -Wcompat -Worphans -Wincomplete-uni-patterns -Wincomplete-record-updates -Wimplicit-prelude -Wmissing-home-modules -Widentities -Wredundant-constraints ghc-options: -fno-ignore-asserts -fexpose-all-unfoldings -fspecialise-aggressively ghc-options: -threaded -rtsopts -- Minimize median lag at the cost of occasional bigger GC lag, -- which fortunately sometimes fits into idle time between turns): ghc-options: -with-rtsopts=-A99m if impl(ghcjs) { -- This is the largest GHCJS_BUSY_YIELD value that does not cause dropped frames -- on my machine with default --maxFps. cpp-options: -DGHCJS_BUSY_YIELD=50 } else { build-depends: zlib >= 0.5.3.1 } LambdaHack-0.8.3.0/Makefile0000644000000000000000000004463413315545734013502 0ustar0000000000000000play: dist/build/LambdaHack/LambdaHack --dbgMsgSer --logPriority 4 --savePrefix play --dumpInitRngs shot: dist/build/LambdaHack/LambdaHack --dbgMsgSer --logPriority 4 --savePrefix play --dumpInitRngs --printEachScreen expose-lore: dist/build/LambdaHack/LambdaHack --dbgMsgSer --logPriority 4 --dumpInitRngs --savePrefix know --newGame 2 --gameMode crawl --knowItems --benchmark --noAnim --maxFps 1000 configure-debug: cabal configure --enable-profiling --profiling-detail=all-functions -fwith_expensive_assertions --disable-optimization configure-prof: cabal configure --enable-profiling --profiling-detail=exported-functions -frelease ghcjs-configure: cabal configure --disable-library-profiling --disable-profiling --ghcjs --ghcjs-option=-dedupe -f-release chrome-prof: google-chrome --no-sandbox --js-flags="--logfile=%t.log --prof" ../lambdahack.github.io/index.html minific: ccjs dist/build/LambdaHack/LambdaHack.jsexe/all.js --compilation_level=ADVANCED_OPTIMIZATIONS --isolation_mode=IIFE --assume_function_wrapper --jscomp_off="*" --externs=node --externs=dist/build/LambdaHack/LambdaHack.jsexe/all.js.externs > ../lambdahack.github.io/lambdahack.all.js # Low delay to display animations swiftly and not bore the public too much. # Delay can't be lower than 2, because browsers sometimes treat delay 1 # specially and add their extra delay. create-gif : find ~/.LambdaHack/screenshots/ -name 'prtscn*.bmp' -print0 | xargs -0 -r mogrify -format gif gifsicle -O3 --careful -d2 -l ~/.LambdaHack/screenshots/prtscn*.gif -o ~/.LambdaHack/screenshots/screenshot.gif frontendRaid: dist/build/LambdaHack/LambdaHack --dbgMsgSer --logPriority 4 --savePrefix test --newGame 5 --dumpInitRngs --automateAll --gameMode raid frontendBrawl: dist/build/LambdaHack/LambdaHack --dbgMsgSer --logPriority 4 --savePrefix test --newGame 5 --dumpInitRngs --automateAll --gameMode brawl frontendShootout: dist/build/LambdaHack/LambdaHack --dbgMsgSer --logPriority 4 --savePrefix test --newGame 5 --dumpInitRngs --automateAll --gameMode shootout frontendEscape: dist/build/LambdaHack/LambdaHack --dbgMsgSer --logPriority 4 --savePrefix test --newGame 3 --dumpInitRngs --automateAll --gameMode escape frontendZoo: dist/build/LambdaHack/LambdaHack --dbgMsgSer --logPriority 4 --savePrefix test --newGame 2 --dumpInitRngs --automateAll --gameMode zoo frontendAmbush: dist/build/LambdaHack/LambdaHack --dbgMsgSer --logPriority 4 --savePrefix test --newGame 5 --dumpInitRngs --automateAll --gameMode ambush frontendCrawl: dist/build/LambdaHack/LambdaHack --dbgMsgSer --logPriority 4 --savePrefix test --newGame 1 --dumpInitRngs --automateAll --gameMode crawl frontendCrawlEmpty: dist/build/LambdaHack/LambdaHack --dbgMsgSer --logPriority 4 --savePrefix test --newGame 1 --dumpInitRngs --automateAll --gameMode "crawl empty" frontendSafari: dist/build/LambdaHack/LambdaHack --dbgMsgSer --logPriority 4 --savePrefix test --newGame 2 --dumpInitRngs --automateAll --gameMode safari frontendSafariSurvival: dist/build/LambdaHack/LambdaHack --dbgMsgSer --logPriority 4 --savePrefix test --newGame 5 --dumpInitRngs --automateAll --gameMode "safari survival" frontendBattle: dist/build/LambdaHack/LambdaHack --dbgMsgSer --logPriority 4 --savePrefix test --newGame 5 --dumpInitRngs --automateAll --gameMode battle frontendBattleSurvival: dist/build/LambdaHack/LambdaHack --dbgMsgSer --logPriority 4 --savePrefix test --newGame 5 --dumpInitRngs --automateAll --gameMode "battle survival" frontendDefense: dist/build/LambdaHack/LambdaHack --dbgMsgSer --logPriority 4 --savePrefix test --newGame 9 --dumpInitRngs --automateAll --gameMode defense frontendDefenseEmpty: dist/build/LambdaHack/LambdaHack --dbgMsgSer --logPriority 4 --savePrefix test --newGame 9 --dumpInitRngs --automateAll --gameMode "defense empty" benchMemoryAnim: dist/build/LambdaHack/LambdaHack --dbgMsgSer --logPriority 4 --newGame 1 --maxFps 100000 --benchmark --stopAfterFrames 33000 --automateAll --keepAutomated --gameMode crawl --setDungeonRng 120 --setMainRng 47 --frontendNull --noAnim +RTS -s -A1M -RTS benchBattle: dist/build/LambdaHack/LambdaHack --dbgMsgSer --logPriority 4 --newGame 3 --noAnim --maxFps 100000 --frontendNull --benchmark --stopAfterFrames 1500 --automateAll --keepAutomated --gameMode battle --setDungeonRng 7 --setMainRng 7 benchAnimBattle: dist/build/LambdaHack/LambdaHack --dbgMsgSer --logPriority 4 --newGame 3 --maxFps 100000 --frontendNull --benchmark --stopAfterFrames 7000 --automateAll --keepAutomated --gameMode battle --setDungeonRng 7 --setMainRng 7 benchFrontendBattle: dist/build/LambdaHack/LambdaHack --dbgMsgSer --logPriority 4 --newGame 3 --noAnim --maxFps 100000 --benchmark --stopAfterFrames 2000 --automateAll --keepAutomated --gameMode battle --setDungeonRng 7 --setMainRng 7 benchCrawl: dist/build/LambdaHack/LambdaHack --dbgMsgSer --logPriority 4 --newGame 1 --noAnim --maxFps 100000 --frontendNull --benchmark --stopAfterFrames 7000 --automateAll --keepAutomated --gameMode crawl --setDungeonRng 0 --setMainRng 0 benchFrontendCrawl: dist/build/LambdaHack/LambdaHack --dbgMsgSer --logPriority 4 --newGame 1 --noAnim --maxFps 100000 --benchmark --stopAfterFrames 7000 --automateAll --keepAutomated --gameMode crawl --setDungeonRng 0 --setMainRng 0 benchNull: benchBattle benchAnimBattle benchCrawl bench: benchBattle benchAnimBattle benchFrontendBattle benchCrawl benchFrontendCrawl nativeBenchCrawl: dist/build/LambdaHack/LambdaHack --dbgMsgSer --logPriority 4 --newGame 2 --noAnim --maxFps 100000 --frontendNull --benchmark --stopAfterFrames 2000 --automateAll --keepAutomated --gameMode crawl --setDungeonRng 0 --setMainRng 0 nativeBenchBattle: dist/build/LambdaHack/LambdaHack --dbgMsgSer --logPriority 4 --newGame 3 --noAnim --maxFps 100000 --frontendNull --benchmark --stopAfterFrames 1000 --automateAll --keepAutomated --gameMode battle --setDungeonRng 0 --setMainRng 0 nativeBench: nativeBenchBattle nativeBenchCrawl nodeBenchCrawl: node dist/build/LambdaHack/LambdaHack.jsexe/all.js --dbgMsgSer --logPriority 4 --newGame 2 --noAnim --maxFps 100000 --frontendNull --benchmark --stopAfterFrames 2000 --automateAll --keepAutomated --gameMode crawl --setDungeonRng 0 --setMainRng 0 nodeBenchBattle: node dist/build/LambdaHack/LambdaHack.jsexe/all.js --dbgMsgSer --logPriority 4 --newGame 3 --noAnim --maxFps 100000 --frontendNull --benchmark --stopAfterFrames 1000 --automateAll --keepAutomated --gameMode battle --setDungeonRng 0 --setMainRng 0 nodeBench: nodeBenchBattle nodeBenchCrawl test-travis: test-short test-medium benchNull test: test-short test-medium benchNull test-short: test-short-new test-short-load test-medium: testRaid-medium testBrawl-medium testShootout-medium testEscape-medium testZoo-medium testAmbush-medium testCrawl-medium testCrawlEmpty-medium testCrawl-medium-know testSafari-medium testSafariSurvival-medium testBattle-medium testBattleSurvival-medium testDefenseEmpty-medium testRaid-medium: dist/build/LambdaHack/LambdaHack --dbgMsgSer --logPriority 4 --boostRandomItem --newGame 5 --maxFps 100000 --frontendTeletype --benchmark --stopAfterSeconds 20 --dumpInitRngs --automateAll --keepAutomated --gameMode raid 2> /tmp/teletypetest.log testBrawl-medium: dist/build/LambdaHack/LambdaHack --dbgMsgSer --logPriority 4 --boostRandomItem --newGame 5 --maxFps 100000 --frontendTeletype --benchmark --stopAfterSeconds 20 --dumpInitRngs --automateAll --keepAutomated --gameMode brawl 2> /tmp/teletypetest.log testShootout-medium: dist/build/LambdaHack/LambdaHack --dbgMsgSer --logPriority 4 --boostRandomItem --newGame 5 --maxFps 100000 --frontendTeletype --benchmark --stopAfterSeconds 20 --dumpInitRngs --automateAll --keepAutomated --gameMode shootout 2> /tmp/teletypetest.log testEscape-medium: dist/build/LambdaHack/LambdaHack --dbgMsgSer --logPriority 4 --boostRandomItem --newGame 3 --maxFps 100000 --frontendTeletype --benchmark --stopAfterSeconds 40 --dumpInitRngs --automateAll --keepAutomated --gameMode escape 2> /tmp/teletypetest.log testZoo-medium: dist/build/LambdaHack/LambdaHack --dbgMsgSer --logPriority 4 --boostRandomItem --newGame 2 --maxFps 100000 --frontendTeletype --benchmark --stopAfterSeconds 40 --dumpInitRngs --automateAll --keepAutomated --gameMode zoo 2> /tmp/teletypetest.log testAmbush-medium: dist/build/LambdaHack/LambdaHack --dbgMsgSer --logPriority 4 --boostRandomItem --newGame 5 --noAnim --maxFps 100000 --frontendTeletype --benchmark --stopAfterSeconds 20 --dumpInitRngs --automateAll --keepAutomated --gameMode ambush 2> /tmp/teletypetest.log testCrawl-medium: dist/build/LambdaHack/LambdaHack --dbgMsgSer --logPriority 4 --newGame 1 --noAnim --maxFps 100000 --frontendTeletype --benchmark --stopAfterSeconds 200 --dumpInitRngs --automateAll --keepAutomated --gameMode crawl 2> /tmp/teletypetest.log testCrawlEmpty-medium: dist/build/LambdaHack/LambdaHack --dbgMsgSer --logPriority 4 --newGame 1 --noAnim --maxFps 100000 --frontendTeletype --benchmark --stopAfterSeconds 40 --dumpInitRngs --automateAll --keepAutomated --gameMode "crawl empty" 2> /tmp/teletypetest.log testCrawl-medium-know: dist/build/LambdaHack/LambdaHack --dbgMsgSer --logPriority 4 --boostRandomItem --savePrefix know --newGame 3 --noAnim --maxFps 100000 --frontendTeletype --benchmark --stopAfterSeconds 100 --dumpInitRngs --automateAll --keepAutomated --gameMode crawl --knowItems 2> /tmp/teletypetest.log testSafari-medium: dist/build/LambdaHack/LambdaHack --dbgMsgSer --logPriority 4 --boostRandomItem --newGame 2 --noAnim --maxFps 100000 --frontendTeletype --benchmark --stopAfterSeconds 100 --dumpInitRngs --automateAll --keepAutomated --gameMode safari 2> /tmp/teletypetest.log testSafariSurvival-medium: dist/build/LambdaHack/LambdaHack --dbgMsgSer --logPriority 4 --boostRandomItem --newGame 8 --noAnim --maxFps 100000 --frontendTeletype --benchmark --stopAfterSeconds 40 --dumpInitRngs --automateAll --keepAutomated --gameMode "safari survival" 2> /tmp/teletypetest.log testBattle-medium: dist/build/LambdaHack/LambdaHack --dbgMsgSer --logPriority 4 --boostRandomItem --newGame 3 --noAnim --maxFps 100000 --frontendTeletype --benchmark --stopAfterSeconds 20 --dumpInitRngs --automateAll --keepAutomated --gameMode battle 2> /tmp/teletypetest.log testBattleSurvival-medium: dist/build/LambdaHack/LambdaHack --dbgMsgSer --logPriority 4 --boostRandomItem --newGame 7 --noAnim --maxFps 100000 --frontendTeletype --benchmark --stopAfterSeconds 40 --dumpInitRngs --automateAll --keepAutomated --gameMode "battle survival" 2> /tmp/teletypetest.log testDefense-medium: dist/build/LambdaHack/LambdaHack --dbgMsgSer --logPriority 4 --boostRandomItem --newGame 9 --noAnim --maxFps 100000 --frontendTeletype --benchmark --stopAfterSeconds 200 --dumpInitRngs --automateAll --keepAutomated --gameMode defense 2> /tmp/teletypetest.log testDefenseEmpty-medium: dist/build/LambdaHack/LambdaHack --dbgMsgSer --logPriority 4 --boostRandomItem --newGame 9 --noAnim --maxFps 100000 --frontendTeletype --benchmark --stopAfterSeconds 40 --dumpInitRngs --automateAll --keepAutomated --gameMode "defense empty" 2> /tmp/teletypetest.log test-short-new: dist/build/LambdaHack/LambdaHack --dbgMsgSer --logPriority 4 --boostRandomItem --newGame 5 --savePrefix raid --dumpInitRngs --automateAll --keepAutomated --gameMode raid --frontendTeletype --stopAfterSeconds 2 2> /tmp/teletypetest.log dist/build/LambdaHack/LambdaHack --dbgMsgSer --logPriority 4 --boostRandomItem --newGame 5 --savePrefix brawl --dumpInitRngs --automateAll --keepAutomated --gameMode brawl --frontendTeletype --stopAfterSeconds 2 2> /tmp/teletypetest.log dist/build/LambdaHack/LambdaHack --dbgMsgSer --logPriority 4 --boostRandomItem --newGame 5 --savePrefix shootout --dumpInitRngs --automateAll --keepAutomated --gameMode shootout --frontendTeletype --stopAfterSeconds 2 2> /tmp/teletypetest.log dist/build/LambdaHack/LambdaHack --dbgMsgSer --logPriority 4 --boostRandomItem --newGame 5 --savePrefix escape --dumpInitRngs --automateAll --keepAutomated --gameMode escape --frontendTeletype --stopAfterSeconds 2 2> /tmp/teletypetest.log dist/build/LambdaHack/LambdaHack --dbgMsgSer --logPriority 4 --boostRandomItem --newGame 5 --savePrefix zoo --dumpInitRngs --automateAll --keepAutomated --gameMode zoo --frontendTeletype --stopAfterSeconds 2 2> /tmp/teletypetest.log dist/build/LambdaHack/LambdaHack --dbgMsgSer --logPriority 4 --boostRandomItem --newGame 5 --savePrefix ambush --dumpInitRngs --automateAll --keepAutomated --gameMode ambush --frontendTeletype --stopAfterSeconds 2 2> /tmp/teletypetest.log dist/build/LambdaHack/LambdaHack --dbgMsgSer --logPriority 4 --boostRandomItem --newGame 5 --savePrefix crawl --dumpInitRngs --automateAll --keepAutomated --gameMode crawl --frontendTeletype --stopAfterSeconds 2 2> /tmp/teletypetest.log dist/build/LambdaHack/LambdaHack --dbgMsgSer --logPriority 4 --boostRandomItem --newGame 5 --savePrefix safari --dumpInitRngs --automateAll --keepAutomated --gameMode safari --frontendTeletype --stopAfterSeconds 2 2> /tmp/teletypetest.log dist/build/LambdaHack/LambdaHack --dbgMsgSer --logPriority 4 --boostRandomItem --newGame 5 --savePrefix safariSurvival --dumpInitRngs --automateAll --keepAutomated --gameMode "safari survival" --frontendTeletype --stopAfterSeconds 2 2> /tmp/teletypetest.log dist/build/LambdaHack/LambdaHack --dbgMsgSer --logPriority 4 --boostRandomItem --newGame 5 --savePrefix battle --dumpInitRngs --automateAll --keepAutomated --gameMode battle --frontendTeletype --stopAfterSeconds 2 2> /tmp/teletypetest.log dist/build/LambdaHack/LambdaHack --dbgMsgSer --logPriority 4 --boostRandomItem --newGame 5 --savePrefix battleSurvival --dumpInitRngs --automateAll --keepAutomated --gameMode "battle survival" --frontendTeletype --stopAfterSeconds 2 2> /tmp/teletypetest.log # "--setDungeonRng 0 --setMainRng 0" is needed for determinism relative to seed # generated before game save test-short-load: dist/build/LambdaHack/LambdaHack --dbgMsgSer --logPriority 4 --boostRandomItem --savePrefix raid --dumpInitRngs --automateAll --keepAutomated --gameMode raid --frontendTeletype --stopAfterSeconds 2 --setDungeonRng 0 --setMainRng 0 2> /tmp/teletypetest.log dist/build/LambdaHack/LambdaHack --dbgMsgSer --logPriority 4 --boostRandomItem --savePrefix brawl --dumpInitRngs --automateAll --keepAutomated --gameMode brawl --frontendTeletype --stopAfterSeconds 2 --setDungeonRng 0 --setMainRng 0 2> /tmp/teletypetest.log dist/build/LambdaHack/LambdaHack --dbgMsgSer --logPriority 4 --boostRandomItem --savePrefix shootout --dumpInitRngs --automateAll --keepAutomated --gameMode shootouti --frontendTeletype --stopAfterSeconds 2 --setDungeonRng 0 --setMainRng 0 2> /tmp/teletypetest.log dist/build/LambdaHack/LambdaHack --dbgMsgSer --logPriority 4 --boostRandomItem --savePrefix escape --dumpInitRngs --automateAll --keepAutomated --gameMode escape --frontendTeletype --stopAfterSeconds 2 --setDungeonRng 0 --setMainRng 0 2> /tmp/teletypetest.log dist/build/LambdaHack/LambdaHack --dbgMsgSer --logPriority 4 --boostRandomItem --savePrefix zoo --dumpInitRngs --automateAll --keepAutomated --gameMode zoo --frontendTeletype --stopAfterSeconds 2 --setDungeonRng 0 --setMainRng 0 2> /tmp/teletypetest.log dist/build/LambdaHack/LambdaHack --dbgMsgSer --logPriority 4 --boostRandomItem --savePrefix ambush --dumpInitRngs --automateAll --keepAutomated --gameMode ambush --frontendTeletype --stopAfterSeconds 2 --setDungeonRng 0 --setMainRng 0 2> /tmp/teletypetest.log dist/build/LambdaHack/LambdaHack --dbgMsgSer --logPriority 4 --boostRandomItem --savePrefix crawl --dumpInitRngs --automateAll --keepAutomated --gameMode crawl --frontendTeletype --stopAfterSeconds 2 --setDungeonRng 0 --setMainRng 0 2> /tmp/teletypetest.log dist/build/LambdaHack/LambdaHack --dbgMsgSer --logPriority 4 --boostRandomItem --savePrefix safari --dumpInitRngs --automateAll --keepAutomated --gameMode safari --frontendTeletype --stopAfterSeconds 2 --setDungeonRng 0 --setMainRng 0 2> /tmp/teletypetest.log dist/build/LambdaHack/LambdaHack --dbgMsgSer --logPriority 4 --boostRandomItem --savePrefix safariSurvival --dumpInitRngs --automateAll --keepAutomated --gameMode "safari survival" --frontendTeletype --stopAfterSeconds 2 --setDungeonRng 0 --setMainRng 0 2> /tmp/teletypetest.log dist/build/LambdaHack/LambdaHack --dbgMsgSer --logPriority 4 --boostRandomItem --savePrefix battle --dumpInitRngs --automateAll --keepAutomated --gameMode battle --frontendTeletype --stopAfterSeconds 2 --setDungeonRng 0 --setMainRng 0 2> /tmp/teletypetest.log dist/build/LambdaHack/LambdaHack --dbgMsgSer --logPriority 4 --boostRandomItem --savePrefix battleSurvival --dumpInitRngs --automateAll --keepAutomated --gameMode "battle survival" --frontendTeletype --stopAfterSeconds 2 --setDungeonRng 0 --setMainRng 0 2> /tmp/teletypetest.log version: dist/build/LambdaHack/LambdaHack --version build-binary-common: cabal install --disable-library-profiling --disable-profiling --disable-documentation -f-release --only-dependencies cabal configure --disable-library-profiling --disable-profiling -f-release --prefix=/ --datadir=. --datasubdir=. cabal build exe:LambdaHack mkdir -p LambdaHackTheGame/GameDefinition/fonts cabal copy --destdir=LambdaHackTheGameInstall cp GameDefinition/config.ui.default LambdaHackTheGame/GameDefinition cp GameDefinition/fonts/16x16x.fon LambdaHackTheGame/GameDefinition/fonts cp GameDefinition/fonts/8x8xb.fon LambdaHackTheGame/GameDefinition/fonts cp GameDefinition/fonts/8x8x.fon LambdaHackTheGame/GameDefinition/fonts cp GameDefinition/fonts/LICENSE.16x16x LambdaHackTheGame/GameDefinition/fonts cp GameDefinition/fonts/Fix15Mono-Bold.woff LambdaHackTheGame/GameDefinition/fonts cp GameDefinition/fonts/LICENSE.Fix15Mono-Bold LambdaHackTheGame/GameDefinition/fonts cp GameDefinition/PLAYING.md LambdaHackTheGame/GameDefinition cp GameDefinition/InGameHelp.txt LambdaHackTheGame/GameDefinition cp README.md LambdaHackTheGame cp CHANGELOG.md LambdaHackTheGame cp LICENSE LambdaHackTheGame cp COPYLEFT LambdaHackTheGame cp CREDITS LambdaHackTheGame build-binary-ubuntu: build-binary-common cp LambdaHackTheGameInstall/bin/LambdaHack LambdaHackTheGame dist/build/LambdaHack/LambdaHack --version > /dev/null; \ LH_VERSION=$$(cat ~/.LambdaHack/stdout.txt); \ tar -czf LambdaHack_$${LH_VERSION}_ubuntu-16.04-amd64.tar.gz LambdaHackTheGame build-binary-macosx: build-binary-common cp LambdaHackTheGameInstall/bin/LambdaHack LambdaHackTheGame dist/build/LambdaHack/LambdaHack --version > /dev/null; \ LH_VERSION=$$(cat ~/.LambdaHack/stdout.txt); \ OS_VERSION=$$(sw_vers -productVersion); \ tar -czf LambdaHack_$${LH_VERSION}_macosx-$${OS_VERSION}-amd64.tar.gz LambdaHackTheGame new-build-dev: cabal new-build --datadir=. --disable-optimization -j1 LambdaHack-0.8.3.0/CHANGELOG.md0000644000000000000000000004376113315545734013653 0ustar0000000000000000## [v0.8.3.0](https://github.com/LambdaHack/LambdaHack/compare/v0.8.1.2...v0.8.3.0) - Add a hack to run SDL2 on the main thread, fixing the OS X crash - Warn visually when impressed and Calm running low, risking domination - Display actor as red when low Calm and impressed or when low HP - Fix, complete and fine tune UI, AI and server skill and weapon checks - Fix a bug where item aspects look different to clients than to the server - Change the requirements for the main menu ASCII art ## [v0.8.1.2](https://github.com/LambdaHack/LambdaHack/compare/v0.8.1.1...v0.8.1.2) - Fix typos detected by lintian - Fix the code that runs in case of old async (bug introduced in v0.8.1.1) ## [v0.8.1.1](https://github.com/LambdaHack/LambdaHack/compare/v0.8.1.0...v0.8.1.1) - no player-visible changes - make it possible to compile with old async package - rewrite copyright information according to Debian format - make github display the correct main license ## [v0.8.1.0](https://github.com/LambdaHack/LambdaHack/compare/v0.8.0.0...v0.8.1.0) - no player-visible changes - significantly reduce RAM usage when compiling library - update and extend CI ## [v0.8.0.0, aka 'Explosive dashboard'](https://github.com/LambdaHack/LambdaHack/compare/v0.7.1.0...v0.8.0.0) - rework greying out menu items and permitting item application and projection - rework history collection; merge message repetitions more aggressively - display HP in red when below (configurable) warning threshold - tweak AI: actors remember they are fleeing; better leader choice, etc. - add to content specialized explosive projectiles; tune the effects - calculate loot score component based on fraction of dungeon loot collected - don't hardwire item price, but let it be specified in content - let all valuables glitter in the dark to avoid complete level exploration - teach AI to cure ailments and shake off impressions - rework detection effects; add detection of items embedded in tiles - automatically identify stolen items that only have minor effects - let projectiles hit each other if fragile and substantial enough - rework item kind identification code; change the way it's defined in content - make more item kinds (including some traps) secret - protect paralyzed actors with a stasis condition to avoid infinite paralysis - implement dumping screenshots in SDL2 and create animated GIFs in Makefile - generate most common consumables less often, but in depth-scaled bunches - make pushed actors alter tiles and trigger effects of embedded items - validate and cross-validate more content; reduce content creation boilerplate - make summoning more varied and prevent chain-summoning - add many ways to conditionally sequence effects - create large, merged rooms more often - generalize the terrain altering player command (C-c, mouse) - let RET, SPACE and ESC clear pending messages, if any - add dashboard with links to all menus and info screens - scale some organ and trap power with level depth - simplify level-scaled dice roll semantics - change scaled dice notation 'dl' to 'dL' for readability in-game - rebalance items and decrease dice variety to unclutter backpack - colour-code beneficial and harmful conditions in menu and in HUD - display item lore (also for organs, embedded items, explosions, etc.) - display embedded item descriptions as if they were tile descriptions - tweak blast visuals, lower particle counts, beautify their spread - tweak projectile visuals, e.g., display an extra frame when projectile dies - add intro screen and work on other ways to convey story - simplify a lot of code, including a bit of game rules - fix some bugs, tweak content, speed up some AI bottlenecks ## [v0.7.1.0, aka 'Ancient troubles'](https://github.com/LambdaHack/LambdaHack/compare/v0.7.0.0...v0.7.1.0) - add amazing cave and item (actor, blast, organ) descriptions - package for Windows as an installer and also as zip archives - fix a crash from SDL frontend under some OpenGL drivers (no thread-safety) - add WWW address to the Main Menu, for other sites that may run our JS blob ## [v0.7.0.0, aka 'The dice are cast'](https://github.com/LambdaHack/LambdaHack/compare/v0.6.2.0...v0.7.0.0) - decouple tile searching from tile alteration - refrain from identifying items that are not randomized - switch away from incapacitated leader to let others revive him - make rescue easier by not going into negative HP the first time - fix crowd of friends on another level slowing even actors that melee - fix missing report about items underneath an actor when changing levels - API breakage: change the syntax of dice in content - API addition: introduce cave descriptions - keep all client states in the server and optimize communication with clients - improve item choice for identification and item polymorphing - reset embedded items when altering tile - replace atomic command filtering with exception catching - reimplement dice as symbolic expressions inducing multiple RNG calls - switch to optparse-applicative and rewrite cli handling - add stack and cabal new-build project files - improve haddocks across the codebase ## [v0.6.2.0, aka 'Zoom out'](https://github.com/LambdaHack/LambdaHack/compare/v0.6.1.0...v0.6.2.0) - make fireworks slower and so easier to spot - make rattlesnake deeper but more common - announce no effect of activation - describe original and current faction of an actor - highlight dominated actors - mark organs with comma instead of percent and gems with dollar - make the healing cave dangerous to prevent camping - slightly balance various content - by default move item the same as last time - often spawn between heroes and stairs going deeper - fix totalUsefulness computation for negative effects - fix abandoning distant enemy target despite no alternatives - fix slow pushing of actors - fix a crash when many actors run towards stairs - hotfix: Pass zoom keys through to the browser - help players find the info about changing the font size - depend on GHC >= 8.0 and new vector - specialize client code already in SampleMonadClient.hs - enable StrictData in all modules - replace 'failure' with 'error' that now shows call stack ## [v0.6.1.0, aka 'Breaking one rule at a time'](https://github.com/LambdaHack/LambdaHack/compare/v0.6.0.0...v0.6.1.0) - fix redrawing after window minimized and restored - hack around vanishing texture on Windows - hack around SDL backends not thread-safe on Windows - the only breaking API change: specify font directory in game rules content - let the game use its own fonts, not fonts from the sample game in library - tweak some item creation to occur in character's pack, not on the ground - slightly balance various content - make sure the 'resolution' effect is not a drawback - make artifact weapon rarities more regular - avoid creating lit, open dungeon at the bottom, where foes have ranged weapons - number scenarios in user descriptions - correct, add and modify some in-game messages - let player hear unseen summonings performed by other actors - don't let actors hear blasts hitting walls, as opposed to hitting actors - when moving item out of shared stash, reset its timeouts - when ascending, shift timeouts of inventory as well - when creating item not on the ground, discover it - when dominating, auto-discover only if the item can't be discovered by use - let henchmen take into account their targets, as described in PLAYING.md - let only walkable tiles be explorable, for clear walls inside solid blocks - move to API 2.0.0 of sdl2-ttf and depend on corrected sdl2 (builds on Windows) - simplify code thanks to the new sdl2-ttf API - tweak travis scripts and building docs in README ## [v0.6.0.0, aka 'Too much to tell'](https://github.com/LambdaHack/LambdaHack/compare/v0.5.0.0...v0.6.0.0) - add and modify a lot of content: items, tiles, embedded items, scenarios - improve AI: targeting, stealth, moving in groups, item use, fleeing, etc. - make monsters more aggressive than animals - tie scenarios into a loose, optional storyline - add more level generators and more variety to room placement - make stairs not walkable and use them by bumping - align stair position on the levels they pass through - introduce noctovision - increase human vision to 12 so that normal speed missiles can be sidestepped - tweak and document weapon damage calculation - derive projectile damage mostly from their speed - make heavy projectiles better vs armor but easier to sidestep - improve hearing of unseen actions, actors and missiles impacts - let some missiles lit up on impact - make torches reusable flares and add blankets for dousing dynamic light - add detection effects and use them in items and tiles - make it possible to catch missiles, if not using weapons - make it possible to wait 0.1 of a turn, at the cost of no bracing - improve pathfinding, prefer less unknown, alterable and dark tiles on paths - slow down actors when acting at the same time, for speed with large factions - don't halve Calm at serious damage any more - eliminate alternative FOV modes, for speed - stop actors blocking FOV, for speed - let actor move diagonally to and from doors, for speed - improve blast (explosion) shapes visually and gameplay-wise - add SDL2 frontend and deprecate GTK frontend - add specialized square bitmap fonts and hack a scalable font - use middle dot instead of period on the map (except in teletype frontend) - add a browser frontend based on DOM, using ghcjs - improve targeting UI, e.g., cycle among items on the map - show an animation when actor teleports - add character stats menu and stat description texts - add item lore and organ lore menus - add a command to sort item slots and perform the sort at startup - add a single item manipulation menu and let it mark an item for later - make history display a menu and improve display of individual messages - display highscore dates according to the local timezone - make the help screen a menu, execute actions directly from it - rework the Main Menu - rework special positions highlight in all frontends - mark leader's target on the map (grey highlight) - visually mark currently chosen menu item and grey out impossible items - define mouse commands based on UI mode and screen area - let the game be fully playable only with mouse, use mouse wheel - pick menu items with mouse and with arrow keys - add more sanity checks for content - reorganize content in files to make rebasing on changed content easier - rework keybinding definition machinery - let clients, not the server, start frontends - version savefiles and move them aside if versions don't match - lots of bug fixes internal improvements and minor visual and text tweaks ## [v0.5.0.0, aka 'Halfway through space'](https://github.com/LambdaHack/LambdaHack/compare/v0.4.101.0...v0.5.0.0) - let AI put excess items in shared stash and use them out of shared stash - let UI multiple items pickup routine put items that don't fit into equipment into shared stash, if possible, not into inventory pack - re-enable the ability to hear close, invisible foes - add a few more AI and autonomous henchmen tactics (CTRL-T) - keep difficulty setting over session restart - change some game start keybindings - replace the Duel game mode with the Raid game mode - various bugfixes, minor improvements and balancing ## [v0.4.101.0, aka 'Officially fun'](https://github.com/LambdaHack/LambdaHack/compare/v0.4.100.0...v0.4.101.0) - the game is now officially fun to play - introduce unique boss monsters and unique artifact items - add animals that heal the player - let AI gang up, attempt stealth and react to player aggressiveness - spawn actors fast and close to the enemy - spawn actors less and less often on a given level, but with growing depth - prefer weapons with effects, if recharged - make the bracing melee bonus additive, not multiplicative - let explosions buffet actors around - make braced actors immune to translocation effects - use mouse for movement, actor selection, aiming - don't run straight with selected actors, but go-to cross-hair with them - speed up default frame rate, slow down projectiles visually - rework item manipulation UI - you can pick up many items at once and it costs only one turn - allow actors to apply and project from the shared stash - reverse messages shown in player diary - display actor organs and stats - split highscore tables wrt game modes - move score calculation formula to content - don't keep the default/example config file commented out; was misleading - I was naughty again and changed v0.5.0.0 of LambdaHack content API slightly one last time ## [v0.4.100.0, aka 'The last thaw'](https://github.com/LambdaHack/LambdaHack/compare/v0.4.99.0...v0.4.100.0) - unexpectedly thaw and freeze again v0.5.0.0 of LambdaHack content API - unexpectedly implement timeouts and temporary effects easily without FRP - make a couple of skill levels meaningful and tweak skills of some actors - make AI prefer exploration of easier levels - permit overfull HP and Calm - let non-projectile actors block view - make colorful characters bold (if it resizes your fonts, turn off via colorIsBold = False in config file or --noColorIsBold on commandline) - start the game with a screensaver safari mode - add i386 Linux and Windows compilation targets to Makefile ## [v0.4.99.0, aka 'Player escapes'](https://github.com/LambdaHack/LambdaHack/compare/v0.2.14...v0.4.99.0) - balance the example game content a bit (campaign still unbalanced) - various code and documentation tweaks and fixes - add cabal flag expose_internal that reveals internal library operations - merge FactionKind into ModeKind and rework completely the semantics - compatibility tweaks for Nixpkgs - define AI tactics, expose them to UI and add one more: follow-the-leader - share leader target between the UI and AI client of each faction - specify monster spawn rate per-cave - extend content validation and make it more user friendly - freeze v0.5.0.0 of LambdaHack content API ## [v0.2.14, aka 'Out of balance'](https://github.com/LambdaHack/LambdaHack/compare/v0.2.12...v0.2.14) - tons of new (unbalanced) content, content fields, effects and descriptions - 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.8.3.0/LICENSE0000644000000000000000000000271413315545734013040 0ustar0000000000000000BSD 3-Clause License All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. LambdaHack-0.8.3.0/Setup.hs0000644000000000000000000000005713315545734013465 0ustar0000000000000000import Distribution.Simple main = defaultMain LambdaHack-0.8.3.0/README.md0000644000000000000000000003131113315545734013305 0ustar0000000000000000LambdaHack ========== [![Build Status](https://travis-ci.org/LambdaHack/LambdaHack.svg?branch=master)](https://travis-ci.org/LambdaHack/LambdaHack) [![Hackage](https://img.shields.io/hackage/v/LambdaHack.svg)](https://hackage.haskell.org/package/LambdaHack) [![Join the chat at https://gitter.im/LambdaHack/LambdaHack](https://badges.gitter.im/LambdaHack/LambdaHack.svg)](https://gitter.im/LambdaHack/LambdaHack?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge&utm_content=badge) LambdaHack is a Haskell[1] game engine library for ASCII roguelike[2] games of arbitrary theme, size and complexity, with optional tactical squad combat. It's packaged together with a sample dungeon crawler in fantasy setting that can be tried out in the browser at http://lambdahack.github.io. (It runs fastest on Chrome. Keyboard commands and savefiles are supported only on recent enough versions of browsers. Mouse should work everywhere.) As an example of the engine's capabilities, here is a showcase of shooting down explosive projectiles. A couple were shot down close enough to enemies to harm them. Others exploded closer to our party members and took out of the air the projectiles that would otherwise harm them. ![gameplay screenshot](https://raw.githubusercontent.com/LambdaHack/media/master/screenshot/allureofthestars.com.shooting.down.explosives.gif) This was a semi-automatic stealthy speedrun of the escape scenario of the sample game that comes with the engine. Small fixed font. The enemy gang has a huge numerical and equipment superiority. Our team loots the area on auto-pilot until the first foe is spotted. Then they scout out enemy positions. Then hero 1 draws enemies and unfortunately enemy fire as well, which is when he valiantly shoots down explosives to avoid the worst damage. Then heroine 2 sneaks behind enemy lines to reach the remaining treasure. That accomplished, the captain signals retreat and leaves for the next area (the zoo). Using the engine ---------------- To use the engine, you need to specify the content to be procedurally generated. You specify what the game world is made of (entities, their relations, physics and lore) and the engine builds the world and runs it. The library lets you compile a ready-to-play game binary, using either the supplied or a custom-made main loop. Several frontends are available (SDL2 is the default for desktop and there is a JavaScript browser frontend) and many other generic engine components are easily overridden, but the fundamental source of flexibility lies in the strict and 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 goals include multiplayer tactical squad combat, in-game content creation, auto-balancing and persistent content modification based on player behaviour. Contributions are welcome. Other games known to use the LambdaHack library: * Allure of the Stars[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] 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). When creating a new game based on LambdaHack I've found it useful to place completely new content at the end of the content files to distinguish from merely modified original LambdaHack content and thus help merging with new releases. Removals of LambdaHack content merge reasonably well, so there are no special considerations. When modifying individual content items, it makes sense to keep their Haskell identifier names and change only in-game names and possibly frequency group names. Installation of the sample game from binary archives ---------------------------------------------------- The game runs rather slowly in the browser (fastest on Chrome) and you are limited to only one font, though it's scalable. Also, savefiles are prone to corruption on the browser, e.g., when it's closed while the game is still saving progress (which takes a long time). Hence, after trying out the game, you may prefer to use a native binary for your architecture, if it exists. Pre-compiled game binaries are available through the release page[11] (and, for Windows, continuously from AppVeyor[18]). To use a pre-compiled binary archive, unpack it and run the executable in the unpacked directory or use program shortcuts from the installer, if available. On Linux, make sure you have the SDL2 libraries installed on your system (e.g., libsdl2-2.0-0, libsdl2-ttf-2.0-0 on Ubuntu). On Mac OS X, you need SDL2 installed, e.g., from [libsdlorg](https://www.libsdl.org/download-2.0.php). For Windows, the SDL2 and all other needed libraries are already contained in the game's binary archive. Note that Windows binaries no longer work on Windows XP, since Cygwin and MSYS2 dropped support for XP. Screen and keyboard configuration --------------------------------- The game UI can be configured via a config file. The default settings, the same that are built into the binary, are in [GameDefinition/config.ui.default](https://github.com/LambdaHack/LambdaHack/blob/master/GameDefinition/config.ui.default). When the game is run for the first time, the file is copied to the default user data folder, which is `~/.LambdaHack/` on Linux, `C:\Users\\AppData\Roaming\LambdaHack\` (or `C:\Documents And Settings\user\Application Data\LambdaHack\` or something else altogether) on Windows, and in RMB menu, under `Inspect/Application/Local Storage` when run inside the Chrome browser. Screen font can be changed by editing the config file in the user data folder. For a small game window, the highly optimized 16x16x.fon and 8x8x.fon bitmap fonts are the best, but for larger window sizes or if you require international characters (e.g. to give custom names to player characters), a modern scalable font supplied with the game is the only option. The game window automatically scales according to the specified font size. If you don't have a numeric keypad, you can use mouse or laptop keys (uk8o79jl) for movement or you can enable the Vi keys (aka roguelike keys) in the config file. If numeric keypad doesn't work, toggling the Num Lock key sometimes helps. If running with the Shift key and keypad keys doesn't work, try Control key instead. The game is fully playable with mouse only, as well as with keyboard only, but the most efficient combination for some players is mouse for go-to, inspecting, and aiming at distant positions and keyboard for everything else. If you are using a terminal frontend, numeric keypad may not work correctly depending on versions of the libraries, terminfo and terminal emulators. Toggling the Num Lock key may help. The curses frontend is not fully supported due to the limitations of the curses library. With the vty frontend started in an xterm, Control-keypad keys for running seem to work OK, but on rxvt they do not. The commands that require pressing Control and Shift together won't work either, but fortunately they are not crucial to gameplay. Compilation of the library and sample game from source ------------------------------------------------------ If you want to compile native 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. The recommended frontend is based on SDL2, so you need the SDL2 libraries for your OS. On Linux, remember to install the -dev versions as well, e.g., libsdl2-dev and libsdl2-ttf-dev on Ubuntu Linux 16.04. (Compilation to JavaScript for the browser is more complicated and requires the ghcjs[15] compiler and optionally the Google Closure Compiler[16] as well.) The latest official version of the LambdaHack library can be downloaded, compiled for SDL2 and installed automatically by Cabal from Hackage[3] as follows cabal update cabal install LambdaHack For a newer snapshot, clone the source code from github[5] and run Cabal from the main directory cabal install There is a built-in black and white line terminal frontend, suitable for teletype terminals or a keyboard and a printer (but it's going to use a lot of paper, unless you disable animations with `--noAnim`). To compile with one of the less rudimentary terminal frontends (in which case you are on your own regarding font choice and color setup and you won't have the spiffy colorful squares around special positions, only crude highlights), use Cabal flags, e.g, cabal install -fvty Testing and debugging --------------------- The [Makefile](https://github.com/LambdaHack/LambdaHack/blob/master/Makefile) contains many sample test commands. Numerous tests that use the screensaver game modes (AI vs. AI) and the teletype frontend are gathered in `make test`. Of these, travis runs `test-travis` on each push to github. Test commands with prefix `frontend` start AI vs. AI games with the standard, user-friendly frontend. Run `LambdaHack --help` to see a brief description of all debug options. Of these, the `--sniff` option is very useful (though verbose and initially cryptic), for displaying the traffic between clients and the server. Some options in the config file may prove useful 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). 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 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. Note that a debug option of the form `--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. Coding style ------------ Stylish Haskell is used for slight auto-formatting at buffer save; see [.stylish-haskell.yaml](https://github.com/LambdaHack/LambdaHack/blob/master/.stylish-haskell.yaml). As defined in the file, indentation is 2 spaces wide and screen is 80-columns wide. Spaces are used, not tabs. Spurious whitespace avoided. Spaces around arithmetic operators encouraged. Generally, relax and try to stick to the style apparent in a file you are editing. Put big formatting changes in separate commits. Haddocks are provided for all module headers and for all functions and types from major modules, in particular the modules that are interfaces for a whole directory of modules. Apart of that, only very important functions and types are distinguished by having a haddock. If minor ones have comments, they should not be haddocks and they are permitted to describe implementation details and be out of date. Prefer assertions to comments, unless too verbose. Further information ------------------- For more information, visit the wiki[4] and see [PLAYING.md](https://github.com/LambdaHack/LambdaHack/blob/master/GameDefinition/PLAYING.md), [CREDITS](https://github.com/LambdaHack/LambdaHack/blob/master/CREDITS) and [COPYLEFT](https://github.com/LambdaHack/LambdaHack/blob/master/COPYLEFT). Have fun! [1]: http://www.haskell.org/ [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 [15]: https://github.com/ghcjs/ghcjs [16]: https://www.npmjs.com/package/google-closure-compiler [18]: https://ci.appveyor.com/project/Mikolaj/lambdahack/build/artifacts LambdaHack-0.8.3.0/Game/0000755000000000000000000000000013315545733012677 5ustar0000000000000000LambdaHack-0.8.3.0/Game/LambdaHack/0000755000000000000000000000000013315545734014647 5ustar0000000000000000LambdaHack-0.8.3.0/Game/LambdaHack/Client.hs0000644000000000000000000000204413315545734016421 0ustar0000000000000000-- | Semantics of responses that are sent from server to clients, -- in terms of client state transformations, -- and semantics of human commands and AI moves, in terms of requests -- to be sent from the client to the server. -- -- See -- . module Game.LambdaHack.Client ( -- * Re-exported from "Game.LambdaHack.Client.LoopM" loopCli -- * Re-exported from "Game.LambdaHack.Client.Request" , RequestAI, ReqAI(..), RequestUI, ReqUI(..), RequestTimed(..) -- * Re-exported from "Game.LambdaHack.Client.Response" , Response (..) -- * Re-exported from "Game.LambdaHack.Client.ClientOptions" , ClientOptions(..), defClientOptions -- * Re-exported from "Game.LambdaHack.Client.UI" , KeyKind , UIOptions, applyUIOptions, uCmdline, mkUIOptions ) where import Prelude () import Game.LambdaHack.Client.ClientOptions import Game.LambdaHack.Client.LoopM import Game.LambdaHack.Client.Request import Game.LambdaHack.Client.Response import Game.LambdaHack.Client.UI LambdaHack-0.8.3.0/Game/LambdaHack/Atomic.hs0000644000000000000000000000157213315545734016424 0ustar0000000000000000-- | Atomic game state transformations, their representation and semantics. -- -- See -- . module Game.LambdaHack.Atomic ( -- * Re-exported from "Game.LambdaHack.Atomic.CmdAtomic" CmdAtomic(..), UpdAtomic(..), SfxAtomic(..), SfxMsg(..) -- * Re-exported from "Game.LambdaHack.Atomic.HandleAtomicWrite" , handleUpdAtomic -- * Re-exported from "Game.LambdaHack.Atomic.PosAtomicRead" , PosAtomic(..), posUpdAtomic, posSfxAtomic, breakUpdAtomic , seenAtomicCli, seenAtomicSer -- * Re-exported from "Game.LambdaHack.Atomic.MonadStateWrite" , MonadStateWrite(..), AtomicFail(..), putState ) where import Prelude () import Game.LambdaHack.Atomic.CmdAtomic import Game.LambdaHack.Atomic.HandleAtomicWrite import Game.LambdaHack.Atomic.MonadStateWrite import Game.LambdaHack.Atomic.PosAtomicRead LambdaHack-0.8.3.0/Game/LambdaHack/Server.hs0000644000000000000000000000144113315545734016451 0ustar0000000000000000-- | Semantics of requests that are sent by clients to the server, -- in terms of game state changes and responses to be sent to the clients. -- -- See -- . module Game.LambdaHack.Server ( -- * Re-exported from "Game.LambdaHack.Server.LoopM" loopSer -- * Re-exported from "Game.LambdaHack.Server.ProtocolM" , ChanServer (..) -- * Re-exported from "Game.LambdaHack.Server.Commandline" , serverOptionsPI -- * Re-exported from "Game.LambdaHack.Server.ServerOptions" , ServerOptions(..) ) where import Prelude () import Game.LambdaHack.Server.Commandline (serverOptionsPI) import Game.LambdaHack.Server.LoopM (loopSer) import Game.LambdaHack.Server.ProtocolM import Game.LambdaHack.Server.ServerOptions LambdaHack-0.8.3.0/Game/LambdaHack/Atomic/0000755000000000000000000000000013315545734016063 5ustar0000000000000000LambdaHack-0.8.3.0/Game/LambdaHack/Atomic/MonadStateWrite.hs0000644000000000000000000003312213315545734021472 0ustar0000000000000000-- | The monad for writing to the main game state. module Game.LambdaHack.Atomic.MonadStateWrite ( MonadStateWrite(..), AtomicFail(..), atomicFail , putState, updateLevel, updateActor, updateFaction, moveActorMap , insertBagContainer, insertItemContainer, insertItemActor , deleteBagContainer, deleteItemContainer, deleteItemActor , addAis, itemsMatch, addItemToActorAspect, resetActorAspect #ifdef EXPOSE_INTERNAL -- * Internal operations , insertItemFloor, insertItemEmbed , insertItemOrgan, insertItemEqp, insertItemInv, insertItemSha , deleteItemFloor, deleteItemEmbed , deleteItemOrgan, deleteItemEqp, deleteItemInv, deleteItemSha , rmFromBag #endif ) where import Prelude () import Game.LambdaHack.Common.Prelude import qualified Control.Exception as Ex import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES import Data.Key (mapWithKeyM_) import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.ItemAspect as IA import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.MonadStateRead import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Content.ItemKind as IK -- | The monad for writing to the main game state. Atomic updates ('UpdAtomic') -- are given semantics in this monad. class MonadStateRead m => MonadStateWrite m where modifyState :: (State -> State) -> m () -- | Exception signifying that atomic action failed because -- the information it carries is inconsistent with the client's state, -- (e.g., because the client knows too little to understand the command -- or already deduced the state change from earlier commands -- or is confused, amnesiac or sees illusory actors or tiles). -- Whenever we know the failure is logically impossible, -- we don't throw the @AtomicFail@ exception, but insert a normal assertion -- or @error@ call, which are never caught nor handled. newtype AtomicFail = AtomicFail String deriving Show instance Ex.Exception AtomicFail atomicFail :: String -> a atomicFail = Ex.throw . AtomicFail putState :: MonadStateWrite m => State -> m () putState s = modifyState (const s) -- INLIning offers no speedup, increases alloc and binary size. -- EM.alter not necessary, because levels not removed, so little risk -- of adjusting at absent index. updateLevel :: MonadStateWrite m => LevelId -> (Level -> Level) -> m () updateLevel lid f = modifyState $ updateDungeon $ EM.adjust f lid -- INLIning doesn't help despite probably canceling the alt indirection. -- perhaps it's applied automatically due to INLINABLE. updateActor :: MonadStateWrite m => ActorId -> (Actor -> Actor) -> m () updateActor aid f = do let alt Nothing = error $ "no body to update" `showFailure` aid alt (Just b) = Just $ f b modifyState $ updateActorD $ EM.alter alt aid updateFaction :: MonadStateWrite m => FactionId -> (Faction -> Faction) -> m () updateFaction fid f = do let alt Nothing = error $ "no faction to update" `showFailure` fid alt (Just fact) = Just $ f fact modifyState $ updateFactionD $ EM.alter alt fid moveActorMap :: MonadStateWrite m => ActorId -> Actor -> Actor -> m () moveActorMap aid body newBody = do let rmActor Nothing = error $ "actor already removed" `showFailure` (aid, body) rmActor (Just l) = #ifdef WITH_EXPENSIVE_ASSERTIONS assert (aid `elem` l `blame` "actor already removed" `swith` (aid, body, l)) #endif (let l2 = delete aid l in if null l2 then Nothing else Just l2) addActor Nothing = Just [aid] addActor (Just l) = #ifdef WITH_EXPENSIVE_ASSERTIONS assert (aid `notElem` l `blame` "actor already added" `swith` (aid, body, l)) #endif (Just $ aid : l) updActor = EM.alter addActor (bpos newBody) . EM.alter rmActor (bpos body) updateLevel (blid body) $ updateActorMap updActor insertBagContainer :: MonadStateWrite m => ItemBag -> Container -> m () insertBagContainer bag c = case c of CFloor lid pos -> do let alt Nothing = Just bag alt (Just bag2) = atomicFail $ "floor bag not empty" `showFailure` (bag2, lid, pos, bag) updateLevel lid $ updateFloor $ EM.alter alt pos CEmbed lid pos -> do let alt Nothing = Just bag alt (Just bag2) = atomicFail $ "embed bag not empty" `showFailure` (bag2, lid, pos, bag) updateLevel lid $ updateEmbed $ EM.alter alt pos CActor aid store -> -- Very unlikely case, so we prefer brevity over performance. mapWithKeyM_ (\iid kit -> insertItemActor iid kit aid store) bag CTrunk{} -> return () insertItemContainer :: MonadStateWrite m => ItemId -> ItemQuant -> Container -> m () insertItemContainer iid kit c = case c of CFloor lid pos -> insertItemFloor iid kit lid pos CEmbed lid pos -> insertItemEmbed iid kit lid pos CActor aid store -> insertItemActor iid kit aid store CTrunk{} -> return () -- New @kit@ lands at the front of the list. insertItemFloor :: MonadStateWrite m => ItemId -> ItemQuant -> LevelId -> Point -> m () insertItemFloor iid kit lid pos = let bag = EM.singleton iid kit mergeBag = EM.insertWith (EM.unionWith mergeItemQuant) pos bag in updateLevel lid $ updateFloor mergeBag insertItemEmbed :: MonadStateWrite m => ItemId -> ItemQuant -> LevelId -> Point -> m () insertItemEmbed iid kit lid pos = let bag = EM.singleton iid kit mergeBag = EM.insertWith (EM.unionWith mergeItemQuant) pos bag in updateLevel lid $ updateEmbed mergeBag insertItemActor :: MonadStateWrite m => ItemId -> ItemQuant -> ActorId -> CStore -> m () insertItemActor iid kit aid cstore = case cstore of CGround -> do b <- getsState $ getActorBody aid insertItemFloor iid kit (blid b) (bpos b) COrgan -> insertItemOrgan iid kit aid CEqp -> insertItemEqp iid kit aid CInv -> insertItemInv iid kit aid CSha -> do b <- getsState $ getActorBody aid insertItemSha iid kit (bfid b) insertItemOrgan :: MonadStateWrite m => ItemId -> ItemQuant -> ActorId -> m () insertItemOrgan iid kit aid = do itemKind <- getsState $ getIidKind iid let bag = EM.singleton iid kit upd = EM.unionWith mergeItemQuant bag updateActor aid $ \b -> b { borgan = upd (borgan b) , bweapon = if IK.isMelee itemKind then bweapon b + 1 else bweapon b } insertItemEqp :: MonadStateWrite m => ItemId -> ItemQuant -> ActorId -> m () insertItemEqp iid kit aid = do itemKind <- getsState $ getIidKind iid let bag = EM.singleton iid kit upd = EM.unionWith mergeItemQuant bag updateActor aid $ \b -> b { beqp = upd (beqp b) , bweapon = if IK.isMelee itemKind then bweapon b + 1 else bweapon 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)} deleteBagContainer :: MonadStateWrite m => ItemBag -> Container -> m () deleteBagContainer bag c = case c of CFloor lid pos -> do let alt Nothing = atomicFail $ "floor bag already empty" `showFailure` (lid, pos, bag) alt (Just bag2) = assert (bag == bag2) Nothing updateLevel lid $ updateFloor $ EM.alter alt pos CEmbed lid pos -> do let alt Nothing = atomicFail $ "embed bag already empty" `showFailure` (lid, pos, bag) alt (Just bag2) = assert (bag == bag2 `blame` (bag, bag2)) Nothing updateLevel lid $ updateEmbed $ EM.alter alt pos CActor aid store -> -- Very unlikely case, so we prefer brevity over performance. mapWithKeyM_ (\iid kit -> deleteItemActor iid kit aid store) bag CTrunk{} -> error $ "" `showFailure` c deleteItemContainer :: MonadStateWrite m => ItemId -> ItemQuant -> Container -> m () deleteItemContainer iid kit c = case c of CFloor lid pos -> deleteItemFloor iid kit lid pos CEmbed lid pos -> deleteItemEmbed iid kit lid pos CActor aid store -> deleteItemActor iid kit aid store CTrunk{} -> error $ "" `showFailure` c deleteItemFloor :: MonadStateWrite m => ItemId -> ItemQuant -> LevelId -> Point -> m () deleteItemFloor iid kit lid pos = let rmFromFloor (Just bag) = let nbag = rmFromBag kit iid bag in if EM.null nbag then Nothing else Just nbag rmFromFloor Nothing = error $ "item already removed" `showFailure` (iid, kit, lid, pos) in updateLevel lid $ updateFloor $ EM.alter rmFromFloor pos deleteItemEmbed :: MonadStateWrite m => ItemId -> ItemQuant -> LevelId -> Point -> m () deleteItemEmbed iid kit lid pos = let rmFromFloor (Just bag) = let nbag = rmFromBag kit iid bag in if EM.null nbag then Nothing else Just nbag rmFromFloor Nothing = error $ "item already removed" `showFailure` (iid, kit, lid, pos) in updateLevel lid $ updateEmbed $ EM.alter rmFromFloor pos deleteItemActor :: MonadStateWrite m => ItemId -> ItemQuant -> ActorId -> CStore -> m () deleteItemActor iid kit aid cstore = case cstore of CGround -> do b <- getsState $ getActorBody aid deleteItemFloor iid kit (blid b) (bpos b) COrgan -> deleteItemOrgan iid kit aid CEqp -> deleteItemEqp iid kit aid CInv -> deleteItemInv iid kit aid CSha -> do b <- getsState $ getActorBody aid deleteItemSha iid kit (bfid b) deleteItemOrgan :: MonadStateWrite m => ItemId -> ItemQuant -> ActorId -> m () deleteItemOrgan iid kit aid = do itemKind <- getsState $ getIidKind iid updateActor aid $ \b -> b { borgan = rmFromBag kit iid (borgan b) , bweapon = if IK.isMelee itemKind then bweapon b - 1 else bweapon b } deleteItemEqp :: MonadStateWrite m => ItemId -> ItemQuant -> ActorId -> m () deleteItemEqp iid kit aid = do itemKind <- getsState $ getIidKind iid updateActor aid $ \b -> b { beqp = rmFromBag kit iid (beqp b) , bweapon = if IK.isMelee itemKind then bweapon b - 1 else bweapon 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 back of the list, -- so that @DestroyItem kit (CreateItem kit x) == x@. rmFromBag :: ItemQuant -> ItemId -> ItemBag -> ItemBag rmFromBag kit@(k, rmIt) iid bag = let rfb Nothing = error $ "rm from empty slot" `showFailure` (k, iid, bag) rfb (Just (n, it)) = case compare n k of LT -> error $ "rm more than there is" `showFailure` (n, kit, iid, bag) EQ -> assert (rmIt == it `blame` (rmIt, it, n, kit, iid, bag)) Nothing GT -> assert (rmIt == take k it `blame` (rmIt, take k it, n, kit, iid, bag)) $ Just (n - k, take (n - k) it) in EM.alter rfb iid bag -- Actor's items may or may not be already present in @sitemD@, -- regardless if they are already present otherwise in the dungeon. -- We re-add them all to save time determining which really need it. -- If collision occurs, pick the item found on easier level. addAis :: MonadStateWrite m => [(ItemId, Item)] -> m () addAis ais = do let h item1 item2 = assert (itemsMatch item1 item2 `blame` "inconsistent added items" `swith` (item1, item2, ais)) item2 -- keep the first found level forM_ ais $ \(iid, item) -> do let f = case jkind item of IdentityObvious _ -> id IdentityCovered ix _ -> updateItemIxMap $ EM.insertWith ES.union ix (ES.singleton iid) modifyState $ f . updateItemD (EM.insertWith h iid item) itemsMatch :: Item -> Item -> Bool itemsMatch item1 item2 = jkind item1 == jkind item2 -- Note that nothing else needs to be the same, since items are merged -- and clients have different views on dungeon items than the server. addItemToActorAspect :: MonadStateWrite m => ItemId -> Item -> Int -> ActorId -> m () addItemToActorAspect iid itemBase k aid = do arItem <- getsState $ aspectRecordFromItem iid itemBase let f arActor = IA.sumAspectRecord [(arActor, 1), (arItem, k)] modifyState $ updateActorAspect $ EM.adjust f aid resetActorAspect :: MonadStateWrite m => m () resetActorAspect = do -- Each actor's equipment and organs would need to be inspected, -- the iid looked up, e.g., if it wasn't in old discoKind, but is in new, -- and then aspect record updated, so it's simpler and not much more -- expensive to generate new sactorAspect. Optimize only after profiling. -- Also note this doesn't get invoked on the server, because it bails out -- earlier, upon noticing the item is already fully known. actorAspect <- getsState actorAspectInDungeon modifyState $ updateActorAspect $ const actorAspect LambdaHack-0.8.3.0/Game/LambdaHack/Atomic/CmdAtomic.hs0000644000000000000000000002561213315545734020265 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(..), SfxMsg(..) , undoUpdAtomic, undoSfxAtomic, undoCmdAtomic ) where import Prelude () import Game.LambdaHack.Common.Prelude import Data.Binary import Data.Int (Int64) import GHC.Generics (Generic) -- Dependence on ClientOptions is an anomaly. Instead, probably the raw -- remaining commandline should be passed and parsed by the client to extract -- client and ui options from and singnal an error if anything was left. import Game.LambdaHack.Client.ClientOptions import Game.LambdaHack.Common.Actor import qualified Game.LambdaHack.Common.Dice as Dice import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.ItemAspect as IA import Game.LambdaHack.Common.Kind import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.Perception import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.ReqFailure 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) -- | 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 it 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 Bool ItemId Item ItemQuant Container | UpdLoseItem Bool ItemId Item ItemQuant Container | UpdSpotItemBag Container ItemBag [(ItemId, Item)] | UpdLoseItemBag Container ItemBag [(ItemId, Item)] -- Move actors and items. | UpdMoveActor ActorId Point Point | UpdWaitActor ActorId Bool | UpdDisplaceActor ActorId ActorId | UpdMoveItem ItemId Int ActorId CStore CStore -- Change actor attributes. | UpdRefillHP ActorId Int64 | UpdRefillCalm ActorId Int64 | UpdTrajectory ActorId (Maybe ([Vector], Speed)) (Maybe ([Vector], Speed)) -- Change faction attributes. | UpdQuitFaction FactionId (Maybe Status) (Maybe Status) | UpdLeadFaction FactionId (Maybe ActorId) (Maybe ActorId) | UpdDiplFaction FactionId FactionId Diplomacy Diplomacy | UpdTacticFaction FactionId Tactic Tactic | UpdAutoFaction FactionId Bool | UpdRecordKill ActorId (ContentId ItemKind) Int -- Alter map. | UpdAlterTile LevelId Point (ContentId TileKind) (ContentId TileKind) | UpdAlterExplorable LevelId Int | UpdAlterGold Int | UpdSearchTile ActorId Point (ContentId TileKind) | UpdHideTile ActorId Point (ContentId TileKind) | UpdSpotTile LevelId [(Point, ContentId TileKind)] | UpdLoseTile LevelId [(Point, ContentId TileKind)] | UpdAlterSmell LevelId Point Time Time | UpdSpotSmell LevelId [(Point, Time)] | UpdLoseSmell LevelId [(Point, Time)] -- Assorted. | UpdTimeItem ItemId Container ItemTimer ItemTimer | UpdAgeGame [LevelId] | UpdUnAgeGame [LevelId] | UpdDiscover Container ItemId (ContentId ItemKind) IA.AspectRecord | UpdCover Container ItemId (ContentId ItemKind) IA.AspectRecord | UpdDiscoverKind Container ItemKindIx (ContentId ItemKind) | UpdCoverKind Container ItemKindIx (ContentId ItemKind) | UpdDiscoverAspect Container ItemId IA.AspectRecord | UpdCoverAspect Container ItemId IA.AspectRecord | UpdDiscoverServer ItemId IA.AspectRecord | UpdCoverServer ItemId IA.AspectRecord | UpdPerception LevelId Perception Perception | UpdRestart FactionId PerLid State Challenge ClientOptions | UpdRestartServer State | UpdResume FactionId PerLid | UpdResumeServer State | UpdKillExit FactionId | UpdWriteSave 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 'State'. data SfxAtomic = SfxStrike ActorId ActorId ItemId CStore | SfxRecoil ActorId ActorId ItemId CStore | SfxSteal ActorId ActorId ItemId CStore | SfxRelease ActorId ActorId ItemId CStore | SfxProject ActorId ItemId CStore | SfxReceive ActorId ItemId CStore | SfxApply ActorId ItemId CStore | SfxCheck ActorId ItemId CStore | SfxTrigger ActorId Point | SfxShun ActorId Point | SfxEffect FactionId ActorId IK.Effect Int64 | SfxMsgFid FactionId SfxMsg | SfxSortSlots | SfxCollideTile ActorId Point deriving (Show, Eq, Generic) instance Binary SfxAtomic -- | Symbolic representation of text messages sent by server to clients -- and shown to players. data SfxMsg = SfxUnexpected ReqFailure | SfxExpected Text ReqFailure | SfxLoudUpd Bool UpdAtomic | SfxLoudStrike Bool (ContentId ItemKind) Int | SfxLoudSummon Bool (GroupName ItemKind) Dice.Dice | SfxFizzles | SfxNothingHappens | SfxVoidDetection IK.DetectKind | SfxUnimpressed ActorId | SfxSummonLackCalm ActorId | SfxLevelNoMore | SfxLevelPushed | SfxBracedImmune ActorId | SfxEscapeImpossible | SfxStasisProtects | SfxTransImpossible | SfxIdentifyNothing | SfxPurposeNothing CStore | SfxPurposeTooFew Int Int | SfxPurposeUnique | SfxPurposeNotCommon | SfxColdFish | SfxTimerExtended LevelId ActorId ItemId CStore | SfxCollideActor LevelId ActorId ActorId deriving (Show, Eq, Generic) instance Binary SfxMsg 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 verbose iid item k c -> Just $ UpdLoseItem verbose iid item k c UpdLoseItem verbose iid item k c -> Just $ UpdSpotItem verbose iid item k c UpdSpotItemBag c bag ais -> Just $ UpdLoseItemBag c bag ais UpdLoseItemBag c bag ais -> Just $ UpdSpotItemBag c bag ais 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 UpdRefillHP aid n -> Just $ UpdRefillHP aid (-n) UpdRefillCalm aid n -> Just $ UpdRefillCalm aid (-n) UpdTrajectory aid fromT toT -> Just $ UpdTrajectory aid toT fromT UpdQuitFaction fid fromSt toSt -> Just $ UpdQuitFaction fid 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 UpdAlterExplorable lid delta -> Just $ UpdAlterExplorable lid (-delta) UpdAlterGold delta -> Just $ UpdAlterGold (-delta) UpdSearchTile aid p toTile -> Just $ UpdHideTile aid p toTile UpdHideTile aid p toTile -> Just $ UpdSearchTile aid p toTile UpdSpotTile lid ts -> Just $ UpdLoseTile lid ts UpdLoseTile lid ts -> Just $ UpdSpotTile lid ts UpdAlterSmell lid p fromSm toSm -> Just $ UpdAlterSmell lid p toSm fromSm UpdSpotSmell lid sms -> Just $ UpdLoseSmell lid sms UpdLoseSmell lid sms -> Just $ UpdSpotSmell lid sms UpdTimeItem iid c fromIt toIt -> Just $ UpdTimeItem iid c toIt fromIt UpdAgeGame lids -> Just $ UpdUnAgeGame lids UpdUnAgeGame lids -> Just $ UpdAgeGame lids UpdDiscover c iid ik aspectRecord -> Just $ UpdCover c iid ik aspectRecord UpdCover c iid ik aspectRecord -> Just $ UpdDiscover c iid ik aspectRecord UpdDiscoverKind c ix ik -> Just $ UpdCoverKind c ix ik UpdCoverKind c ix ik -> Just $ UpdDiscoverKind c ix ik UpdDiscoverAspect c iid aspectRecord -> Just $ UpdCoverAspect c iid aspectRecord UpdCoverAspect c iid aspectRecord -> Just $ UpdDiscoverAspect c iid aspectRecord UpdDiscoverServer iid aspectRecord -> Just $ UpdCoverServer iid aspectRecord UpdCoverServer iid aspectRecord -> Just $ UpdDiscoverServer iid aspectRecord 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 undoSfxAtomic :: SfxAtomic -> SfxAtomic undoSfxAtomic cmd = case cmd of SfxStrike source target iid cstore -> SfxRecoil source target iid cstore SfxRecoil source target iid cstore -> SfxStrike source target iid cstore SfxSteal source target iid cstore -> SfxRelease source target iid cstore SfxRelease source target iid cstore -> SfxSteal source target iid cstore SfxProject aid iid cstore -> SfxReceive aid iid cstore SfxReceive 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 -> SfxShun aid p SfxShun aid p -> SfxTrigger aid p SfxEffect{} -> cmd -- not ideal? SfxMsgFid{} -> cmd SfxSortSlots -> cmd SfxCollideTile{} -> cmd undoCmdAtomic :: CmdAtomic -> Maybe CmdAtomic undoCmdAtomic (UpdAtomic cmd) = UpdAtomic <$> undoUpdAtomic cmd undoCmdAtomic (SfxAtomic sfx) = Just $ SfxAtomic $ undoSfxAtomic sfx LambdaHack-0.8.3.0/Game/LambdaHack/Atomic/HandleAtomicWrite.hs0000644000000000000000000007052113315545734021767 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} -- | Semantics of atomic commands shared by client and server. -- -- See -- . module Game.LambdaHack.Atomic.HandleAtomicWrite ( handleUpdAtomic #ifdef EXPOSE_INTERNAL -- * Internal operations , updCreateActor, updDestroyActor, updCreateItem, updDestroyItem , updSpotItemBag, updLoseItemBag , updMoveActor, updWaitActor, updDisplaceActor, updMoveItem , updRefillHP, updRefillCalm , updTrajectory, updQuitFaction, updLeadFaction , updDiplFaction, updTacticFaction, updAutoFaction, updRecordKill , updAlterTile, updAlterExplorable, updSearchTile, updSpotTile, updLoseTile , updAlterSmell, updSpotSmell, updLoseSmell, updTimeItem , updAgeGame, updUnAgeGame, ageLevel, updDiscover, updCover , updDiscoverKind, discoverKind, updCoverKind , updDiscoverAspect, discoverAspect, updCoverAspect , updDiscoverServer, updCoverServer , updRestart, updRestartServer, updResumeServer #endif ) where import Prelude () import Game.LambdaHack.Common.Prelude import qualified Data.EnumMap.Strict as EM import Data.Int (Int64) import Game.LambdaHack.Atomic.CmdAtomic import Game.LambdaHack.Atomic.MonadStateWrite import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.ItemAspect as IA import Game.LambdaHack.Common.Kind import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.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 qualified Game.LambdaHack.Content.ItemKind as IK import Game.LambdaHack.Content.ModeKind import Game.LambdaHack.Content.TileKind (TileKind, unknownId) -- | The game-state semantics of atomic game commands. -- There is no corresponding definition for special effects (`SfxAtomic`), -- because they don't modify 'State'. -- -- For each of the commands, we are guaranteed that the client, -- the command is addressed to, perceives all the positions the command -- affects (as computed by 'Game.LambdaHack.Atomic.PosAtomicRead.posUpdAtomic'). -- In the code for each semantic function we additonally verify -- the client is aware of any relevant items and/or actors and we throw -- the @AtomicFail@ exception if it's not. -- The server keeps copies of all clients' states and, before sending a command -- to a client, applies it to the client's state copy. -- If @AtomicFail@ is signalled, the command is ignored for that client. -- This enables simpler server code that addresses commands to all clients -- that can see it, even though not all are able to process it. handleUpdAtomic :: MonadStateWrite m => UpdAtomic -> m () handleUpdAtomic cmd = case cmd of 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 UpdSpotItemBag c bag ais -> updSpotItemBag c bag ais UpdLoseItemBag c bag ais -> updLoseItemBag c bag ais 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 UpdRefillHP aid n -> updRefillHP aid n UpdRefillCalm aid n -> updRefillCalm aid n UpdTrajectory aid fromT toT -> updTrajectory aid fromT toT UpdQuitFaction fid fromSt toSt -> updQuitFaction fid fromSt toSt 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 UpdAlterExplorable lid delta -> updAlterExplorable lid delta UpdAlterGold delta -> updAlterGold delta UpdSearchTile aid p toTile -> updSearchTile aid p toTile UpdHideTile{} -> undefined UpdSpotTile lid ts -> updSpotTile lid ts UpdLoseTile lid ts -> updLoseTile lid ts UpdAlterSmell lid p fromSm toSm -> updAlterSmell lid p fromSm toSm UpdSpotSmell lid sms -> updSpotSmell lid sms UpdLoseSmell lid sms -> updLoseSmell lid sms UpdTimeItem iid c fromIt toIt -> updTimeItem iid c fromIt toIt UpdAgeGame lids -> updAgeGame lids UpdUnAgeGame lids -> updUnAgeGame lids UpdDiscover c iid ik aspectRecord -> updDiscover c iid ik aspectRecord UpdCover c iid ik aspectRecord -> updCover c iid ik aspectRecord UpdDiscoverKind c ix ik -> updDiscoverKind c ix ik UpdCoverKind c ix ik -> updCoverKind c ix ik UpdDiscoverAspect c iid aspectRecord -> updDiscoverAspect c iid aspectRecord UpdCoverAspect c iid aspectRecord -> updCoverAspect c iid aspectRecord UpdDiscoverServer iid aspectRecord -> updDiscoverServer iid aspectRecord UpdCoverServer iid aspectRecord -> updCoverServer iid aspectRecord 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 () -- 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@. -- The exception is possible, e.g., when we teleport and so see our actor -- at the new location, but also the location is part of new perception, -- so @UpdSpotActor@ is sent. let f Nothing = Just body f (Just b) = assert (body == b `blame` (aid, body, b)) $ atomicFail $ "actor already added" `showFailure` (aid, body, b) modifyState $ updateActorD $ EM.alter f aid -- Add actor to @sprio@. let g Nothing = Just [aid] g (Just l) = #ifdef WITH_EXPENSIVE_ASSERTIONS -- Not so much expensive, as doubly impossible. assert (aid `notElem` l `blame` "actor already added" `swith` (aid, body, l)) #endif (Just $ aid : l) updateLevel (blid body) $ updateActorMap (EM.alter g (bpos body)) addAis ais aspectRecord <- getsState $ aspectRecordFromActor body modifyState $ updateActorAspect $ EM.insert aid aspectRecord -- If a leader dies, a new leader should be elected on the server -- before this command is executed (not checked). updDestroyActor :: MonadStateWrite m => ActorId -> Actor -> [(ItemId, Item)] -> m () updDestroyActor aid body ais = do -- Assert that actor's items belong to @sitemD@. Do not remove those -- that do not appear anywhere else, for simplicity and speed. itemD <- getsState sitemD let match (iid, item) = itemsMatch (itemD EM.! iid) item let !_A = assert (allB match ais `blame` "destroyed actor items not found" `swith` (aid, body, ais, itemD)) () -- Remove actor from @sactorD@. let f Nothing = error $ "actor already removed" `showFailure` (aid, body) f (Just b) = assert (b == body `blame` "inconsistent destroyed actor body" `swith` (aid, body, b)) Nothing modifyState $ updateActorD $ EM.alter f aid -- Remove actor from @lactor@. let g Nothing = error $ "actor already removed" `showFailure` (aid, body) g (Just l) = #ifdef WITH_EXPENSIVE_ASSERTIONS -- Not so much expensive, as doubly impossible. assert (aid `elem` l `blame` "actor already removed" `swith` (aid, body, l)) #endif (let l2 = delete aid l in if null l2 then Nothing else Just l2) updateLevel (blid body) $ updateActorMap (EM.alter g (bpos body)) modifyState $ updateActorAspect $ EM.delete aid -- 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 addAis [(iid, item)] insertItemContainer iid kit c case c of CActor aid store -> when (store `elem` [CEqp, COrgan]) $ addItemToActorAspect iid item k aid _ -> return () -- 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 deleteItemContainer iid kit c -- Do not remove the item from @sitemD@ nor from @sitemRev@ -- nor from @DiscoveryAspect@, @ItemIxMap@, etc. -- It's incredibly costly and not particularly noticeable for the player. -- Moreover, copies of the item may reappear in the future -- and then we save computation and the player remembers past discovery. -- However, assert the item is registered in @sitemD@. itemD <- getsState sitemD let !_A = assert ((case iid `EM.lookup` itemD of Nothing -> False Just item0 -> itemsMatch item0 item) `blame` "item already removed" `swith` (iid, item, itemD)) () case c of CActor aid store -> when (store `elem` [CEqp, COrgan]) $ addItemToActorAspect iid item (-k) aid _ -> return () updSpotItemBag :: MonadStateWrite m => Container -> ItemBag -> [(ItemId, Item)] -> m () updSpotItemBag c bag ais = assert (EM.size bag > 0 && EM.size bag == length ais) $ do addAis ais insertBagContainer bag c case c of CActor aid store -> when (store `elem` [CEqp, COrgan]) $ forM_ ais $ \(iid, item) -> addItemToActorAspect iid item (fst $ bag EM.! iid) aid _ -> return () updLoseItemBag :: MonadStateWrite m => Container -> ItemBag -> [(ItemId, Item)] -> m () updLoseItemBag c bag ais = assert (EM.size bag > 0 && EM.size bag == length ais) $ do deleteBagContainer bag c -- Do not remove the items from @sitemD@ nor from @sitemRev@, -- It's incredibly costly and not noticeable for the player. -- However, assert the items are registered in @sitemD@. itemD <- getsState sitemD let match (iid, item) = itemsMatch (itemD EM.! iid) item let !_A = assert (allB match ais `blame` "items already removed" `swith` (c, bag, ais, itemD)) () case c of CActor aid store -> when (store `elem` [CEqp, COrgan]) $ forM_ ais $ \(iid, item) -> addItemToActorAspect iid item (- (fst $ bag EM.! iid)) aid _ -> return () updMoveActor :: MonadStateWrite m => ActorId -> Point -> Point -> m () updMoveActor aid fromP toP = assert (fromP /= toP) $ do body <- getsState $ getActorBody aid let !_A = assert (fromP == bpos body `blame` "unexpected moved actor position" `swith` (aid, fromP, toP, bpos body, body)) () newBody = body {bpos = toP, boldpos = Just fromP} updateActor aid $ const newBody moveActorMap aid body newBody updWaitActor :: MonadStateWrite m => ActorId -> Bool -> m () updWaitActor aid toWait = do b <- getsState $ getActorBody aid let !_A = assert (toWait /= bwait b `blame` "unexpected waited actor time" `swith` (aid, toWait, bwait b, b)) () updateActor aid $ \body -> body {bwait = toWait} updDisplaceActor :: MonadStateWrite m => ActorId -> ActorId -> m () updDisplaceActor source target = assert (source /= target) $ do sbody <- getsState $ getActorBody source tbody <- getsState $ getActorBody target let spos = bpos sbody tpos = bpos tbody snewBody = sbody {bpos = tpos, boldpos = Just spos} tnewBody = tbody {bpos = spos, boldpos = Just tpos} updateActor source $ const snewBody updateActor target $ const tnewBody moveActorMap source sbody snewBody moveActorMap target tbody tnewBody updMoveItem :: MonadStateWrite m => ItemId -> Int -> ActorId -> CStore -> CStore -> m () updMoveItem iid k aid s1 s2 = assert (k > 0 && s1 /= s2) $ do b <- getsState $ getActorBody aid bag <- getsState $ getBodyStoreBag b s1 case iid `EM.lookup` bag of Nothing -> error $ "" `showFailure` (iid, k, aid, s1, s2) Just (_, it) -> do deleteItemActor iid (k, take k it) aid s1 insertItemActor iid (k, take k it) aid s2 case s1 of CEqp -> case s2 of COrgan -> return () _ -> do itemBase <- getsState $ getItemBody iid addItemToActorAspect iid itemBase (-k) aid COrgan -> case s2 of CEqp -> return () _ -> do itemBase <- getsState $ getItemBody iid addItemToActorAspect iid itemBase (-k) aid _ -> when (s2 `elem` [CEqp, COrgan]) $ do itemBase <- getsState $ getItemBody iid addItemToActorAspect iid itemBase k aid updRefillHP :: MonadStateWrite m => ActorId -> Int64 -> m () updRefillHP aid nRaw = updateActor aid $ \b -> -- Make rescue easier by not going into negative HP the first time. let newRawHP = bhp b + nRaw newHP = if bhp b <= 0 then newRawHP else max 0 newRawHP n = newHP - bhp b in b { bhp = newHP , bhpDelta = let oldD = bhpDelta b in case compare n 0 of EQ -> ResDelta { resCurrentTurn = (0, 0) , resPreviousTurn = resCurrentTurn oldD } LT -> oldD {resCurrentTurn = ( fst (resCurrentTurn oldD) + n , snd (resCurrentTurn oldD) )} GT -> oldD {resCurrentTurn = ( fst (resCurrentTurn oldD) , snd (resCurrentTurn oldD) + n )} } updRefillCalm :: MonadStateWrite m => ActorId -> Int64 -> m () updRefillCalm aid n = updateActor aid $ \b -> b { bcalm = max 0 $ bcalm b + n , bcalmDelta = let oldD = bcalmDelta b in case compare n 0 of EQ -> ResDelta { resCurrentTurn = (0, 0) , resPreviousTurn = resCurrentTurn oldD } LT -> oldD {resCurrentTurn = ( fst (resCurrentTurn oldD) + n , snd (resCurrentTurn oldD) )} GT -> oldD {resCurrentTurn = ( fst (resCurrentTurn oldD) , snd (resCurrentTurn oldD) + n )} } updTrajectory :: MonadStateWrite m => ActorId -> Maybe ([Vector], Speed) -> Maybe ([Vector], Speed) -> m () updTrajectory aid fromT toT = assert (fromT /= toT) $ do body <- getsState $ getActorBody aid let !_A = assert (fromT == btrajectory body `blame` "unexpected actor trajectory" `swith` (aid, fromT, toT, body)) () updateActor aid $ \b -> b {btrajectory = toT} updQuitFaction :: MonadStateWrite m => FactionId -> Maybe Status -> Maybe Status -> m () updQuitFaction fid fromSt toSt = do let !_A = assert (fromSt /= toSt `blame` (fid, fromSt, toSt)) () fact <- getsState $ (EM.! fid) . sfactionD let !_A = assert (fromSt == gquit fact `blame` "unexpected actor quit status" `swith` (fid, fromSt, toSt, fact)) () let adj fa = fa {gquit = toSt} updateFaction fid adj -- The previous leader is assumed to be alive. updLeadFaction :: MonadStateWrite m => FactionId -> Maybe ActorId -> Maybe ActorId -> m () updLeadFaction fid source target = assert (source /= target) $ do fact <- getsState $ (EM.! fid) . sfactionD let !_A = assert (fleaderMode (gplayer fact) /= LeaderNull) () -- @PosNone@ ensures this mtb <- getsState $ \s -> flip getActorBody s <$> target let !_A = assert (maybe True (not . bproj) mtb `blame` (fid, source, target, mtb, fact)) () let !_A = assert (source == gleader fact `blame` "unexpected actor leader" `swith` (fid, source, target, mtb, fact)) () let adj fa = fa {_gleader = target} updateFaction fid adj updDiplFaction :: MonadStateWrite m => FactionId -> FactionId -> Diplomacy -> Diplomacy -> m () updDiplFaction fid1 fid2 fromDipl toDipl = assert (fid1 /= fid2 && fromDipl /= toDipl) $ do fact1 <- getsState $ (EM.! fid1) . sfactionD fact2 <- getsState $ (EM.! fid2) . sfactionD let !_A = assert (fromDipl == EM.findWithDefault Unknown fid2 (gdipl fact1) && fromDipl == EM.findWithDefault Unknown fid1 (gdipl fact2) `blame` "unexpected actor diplomacy status" `swith` (fid1, fid2, fromDipl, toDipl, fact1, fact2)) () let adj fid fact = fact {gdipl = EM.insert fid toDipl (gdipl fact)} updateFaction fid1 (adj fid2) updateFaction fid2 (adj fid1) 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 updAutoFaction :: MonadStateWrite m => FactionId -> Bool -> m () updAutoFaction fid st = updateFaction fid (\fact -> assert (isAIFact fact == not st) $ fact {gplayer = automatePlayer st (gplayer fact)}) -- Record a given number (usually just 1, or -1 for undo) of actor kills -- for score calculation. updRecordKill :: MonadStateWrite m => ActorId -> ContentId ItemKind -> Int -> m () updRecordKill aid ikind k = do b <- getsState $ getActorBody aid let !_A = assert (not (bproj b) `blame` (aid, b)) let alterKind mn = let n = fromMaybe 0 mn + k in if n == 0 then Nothing else Just n adjFact fact = fact {gvictims = EM.alter alterKind ikind $ gvictims fact} updateFaction (bfid b) adjFact -- The death of a dominated actor counts as the dominating faction's loss -- for score purposes, so human nor AI can't treat such actor as disposable, -- which means domination will not be as cruel, as frustrating, -- as it could be and there is a higher chance of getting back alive -- the actor, the human player has grown attached to. -- Alter an attribute (actually, the only, the defining attribute) -- of a visible tile. This is similar to e.g., @UpdTrajectory@. -- -- Removing and creating embedded items when altering a tile -- is done separately via @UpdCreateItem@ and @UpdDestroyItem@. updAlterTile :: MonadStateWrite m => LevelId -> Point -> ContentId TileKind -> ContentId TileKind -> m () updAlterTile lid p fromTile toTile = assert (fromTile /= toTile) $ do COps{coTileSpeedup} <- getsState scops lvl <- getLevel lid let t = lvl `at` p if t /= fromTile then atomicFail "tile to alter is different than assumed" else do let adj ts = ts PointArray.// [(p, toTile)] updateLevel lid $ updateTile adj case ( Tile.isExplorable coTileSpeedup fromTile , Tile.isExplorable coTileSpeedup toTile ) of (False, True) -> updateLevel lid $ \lvl2 -> lvl2 {lseen = lseen lvl + 1} (True, False) -> updateLevel lid $ \lvl2 -> lvl2 {lseen = lseen lvl - 1} _ -> return () updAlterExplorable :: MonadStateWrite m => LevelId -> Int -> m () updAlterExplorable lid delta = assert (delta /= 0) $ updateLevel lid $ \lvl -> lvl {lexpl = lexpl lvl + delta} updAlterGold :: MonadStateWrite m => Int -> m () updAlterGold delta = assert (delta /= 0) $ modifyState $ updateGold (+ delta) -- Showing to the client the embedded items, if any, is done elsewhere. updSearchTile :: MonadStateWrite m => ActorId -> Point -> ContentId TileKind -> m () updSearchTile aid p toTile = do COps{cotile} <- getsState scops b <- getsState $ getActorBody aid lvl <- getLevel $ blid b let t = lvl `at` p if t == toTile then atomicFail "tile already searched" else assert (Just t == Tile.hideAs cotile toTile) $ do updLoseTile (blid b) [(p, t)] updSpotTile (blid b) [(p, toTile)] -- not the hidden version this one time -- Notice previously invisible tiles. This is done in bulk, -- because it often involves dozens of tiles per move. -- We verify that the old tiles at the positions in question -- are indeed unknown. updSpotTile :: MonadStateWrite m => LevelId -> [(Point, ContentId TileKind)] -> m () updSpotTile lid ts = assert (not $ null ts) $ do COps{coTileSpeedup} <- getsState scops let unk tileMap (p, _) = tileMap PointArray.! p == unknownId adj tileMap = assert (all (unk tileMap) ts) $ tileMap PointArray.// ts updateLevel lid $ updateTile adj let f (_, t1) = when (Tile.isExplorable coTileSpeedup t1) $ updateLevel lid $ \lvl -> lvl {lseen = lseen lvl + 1} mapM_ f ts -- Stop noticing previously visible tiles. It verifies -- the state of the tiles before wiping them out. updLoseTile :: MonadStateWrite m => LevelId -> [(Point, ContentId TileKind)] -> m () updLoseTile lid ts = assert (not $ null ts) $ do COps{coTileSpeedup} <- getsState scops let matches tileMap (p, ov) = tileMap PointArray.! p == ov tu = map (second (const unknownId)) ts adj tileMap = assert (all (matches tileMap) ts) $ tileMap PointArray.// tu updateLevel lid $ updateTile adj let f (_, t1) = when (Tile.isExplorable coTileSpeedup t1) $ updateLevel lid $ \lvl -> lvl {lseen = lseen lvl - 1} mapM_ f ts updAlterSmell :: MonadStateWrite m => LevelId -> Point -> Time -> Time -> m () updAlterSmell lid p fromSm' toSm' = do let fromSm = if fromSm' == timeZero then Nothing else Just fromSm' toSm = if toSm' == timeZero then Nothing else Just toSm' alt sm = assert (sm == fromSm `blame` "unexpected tile smell" `swith` (lid, p, fromSm, toSm, sm)) toSm updateLevel lid $ updateSmell $ EM.alter alt p updSpotSmell :: MonadStateWrite m => LevelId -> [(Point, Time)] -> m () updSpotSmell lid sms = assert (not $ null sms) $ do let alt sm Nothing = Just sm alt sm (Just oldSm) = error $ "smell already added" `showFailure` (lid, sms, sm, oldSm) f (p, sm) = EM.alter (alt sm) p upd m = foldr f m sms updateLevel lid $ updateSmell upd updLoseSmell :: MonadStateWrite m => LevelId -> [(Point, Time)] -> m () updLoseSmell lid sms = assert (not $ null sms) $ do let alt sm Nothing = error $ "smell already removed" `showFailure` (lid, sms, sm) alt sm (Just oldSm) = assert (sm == oldSm `blame` "unexpected lost smell" `swith` (lid, sms, sm, oldSm)) Nothing f (p, sm) = EM.alter (alt sm) p upd m = foldr f m sms updateLevel lid $ updateSmell upd updTimeItem :: MonadStateWrite m => ItemId -> Container -> ItemTimer -> ItemTimer -> m () updTimeItem iid c fromIt toIt = assert (fromIt /= toIt) $ do bag <- getsState $ getContainerBag c case iid `EM.lookup` bag of Just (k, it) -> do let !_A = assert (fromIt == it `blame` (k, it, iid, c, fromIt, toIt)) () deleteItemContainer iid (k, fromIt) c insertItemContainer iid (k, toIt) c Nothing -> error $ "" `showFailure` (bag, iid, c, fromIt, toIt) updAgeGame :: MonadStateWrite m => [LevelId] -> m () updAgeGame lids = do modifyState $ updateTime $ flip timeShift (Delta timeClip) mapM_ (ageLevel (Delta timeClip)) lids updUnAgeGame :: MonadStateWrite m => [LevelId] -> m () updUnAgeGame lids = do modifyState $ updateTime $ flip timeShift (timeDeltaReverse $ Delta timeClip) mapM_ (ageLevel (timeDeltaReverse $ Delta timeClip)) lids ageLevel :: MonadStateWrite m => Delta Time -> LevelId -> m () ageLevel delta lid = updateLevel lid $ \lvl -> lvl {ltime = timeShift (ltime lvl) delta} updDiscover :: MonadStateWrite m => Container -> ItemId -> ContentId ItemKind -> IA.AspectRecord -> m () updDiscover _c iid ik aspectRecord = do itemD <- getsState sitemD COps{coItemSpeedup} <- getsState scops let kmIsConst = IA.kmConst $ IK.getKindMean ik coItemSpeedup discoKind <- getsState sdiscoKind let discoverAtMostAspect = do discoAspect <- getsState sdiscoAspect if kmIsConst || iid `EM.member` discoAspect then atomicFail "item already fully discovered" else discoverAspect iid aspectRecord case EM.lookup iid itemD of Nothing -> atomicFail "discovered item unheard of" Just item -> case jkind item of IdentityObvious _ -> discoverAtMostAspect IdentityCovered ix _ik -> case EM.lookup ix discoKind of Just{} -> discoverAtMostAspect Nothing -> do discoverKind ix ik unless kmIsConst $ discoverAspect iid aspectRecord resetActorAspect updCover :: Container -> ItemId -> ContentId ItemKind -> IA.AspectRecord -> m () updCover _c _iid _ik _aspectRecord = undefined updDiscoverKind :: MonadStateWrite m => Container -> ItemKindIx -> ContentId ItemKind -> m () updDiscoverKind _c ix kmKind = do discoKind <- getsState sdiscoKind if ix `EM.member` discoKind then atomicFail "item kind already discovered" else do discoverKind ix kmKind resetActorAspect discoverKind :: MonadStateWrite m => ItemKindIx -> ContentId ItemKind -> m () discoverKind ix kindId = do let f Nothing = Just kindId f Just{} = error $ "already discovered" `showFailure` (ix, kindId) modifyState $ updateDiscoKind $ \discoKind1 -> EM.alter f ix discoKind1 updCoverKind :: Container -> ItemKindIx -> ContentId ItemKind -> m () updCoverKind _c _ix _ik = undefined updDiscoverAspect :: MonadStateWrite m => Container -> ItemId -> IA.AspectRecord -> m () updDiscoverAspect _c iid aspectRecord = do COps{coItemSpeedup} <- getsState scops itemD <- getsState sitemD case EM.lookup iid itemD of Nothing -> atomicFail "discovered item unheard of" Just item -> do -- Here the kind information is exact, hence @getItemKindIdServer@. kindId <- getsState $ getItemKindIdServer item discoAspect <- getsState sdiscoAspect let kmIsConst = IA.kmConst $ IK.getKindMean kindId coItemSpeedup if kmIsConst || iid `EM.member` discoAspect then atomicFail "item aspectRecord already discovered" else do discoverAspect iid aspectRecord resetActorAspect discoverAspect :: MonadStateWrite m => ItemId -> IA.AspectRecord -> m () discoverAspect iid aspectRecord = do let f Nothing = Just aspectRecord f Just{} = error $ "already discovered" `showFailure` (iid, aspectRecord) -- At this point we know the item is not @kmConst@. modifyState $ updateDiscoAspect $ \discoAspect1 -> EM.alter f iid discoAspect1 updCoverAspect :: Container -> ItemId -> IA.AspectRecord -> m () updCoverAspect _c _iid _aspectRecord = undefined updDiscoverServer :: MonadStateWrite m => ItemId -> IA.AspectRecord -> m () updDiscoverServer iid aspectRecord = modifyState $ updateDiscoAspect $ \discoAspect1 -> EM.insert iid aspectRecord discoAspect1 updCoverServer :: MonadStateWrite m => ItemId -> IA.AspectRecord -> m () updCoverServer iid aspectRecord = modifyState $ updateDiscoAspect $ \discoAspect1 -> assert (discoAspect1 EM.! iid == aspectRecord) $ EM.delete iid discoAspect1 updRestart :: MonadStateWrite m => State -> m () updRestart = putState updRestartServer :: MonadStateWrite m => State -> m () updRestartServer = putState updResumeServer :: MonadStateWrite m => State -> m () updResumeServer = putState LambdaHack-0.8.3.0/Game/LambdaHack/Atomic/PosAtomicRead.hs0000644000000000000000000002672213315545734021122 0ustar0000000000000000-- | Representation and computation of visiblity of atomic commands -- by clients. -- -- See -- . module Game.LambdaHack.Atomic.PosAtomicRead ( PosAtomic(..), posUpdAtomic, posSfxAtomic , breakUpdAtomic, seenAtomicCli, seenAtomicSer #ifdef EXPOSE_INTERNAL -- * Internal operations , posProjBody, singleAid, doubleAid, singleContainer #endif ) where import Prelude () import Game.LambdaHack.Common.Prelude import qualified Data.EnumSet as ES import Game.LambdaHack.Atomic.CmdAtomic import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.MonadStateRead import Game.LambdaHack.Common.Perception import Game.LambdaHack.Common.Point -- 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, server doesn't | 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 or, more -- generally, the conditions under which the update can be noticed by -- a client. -- -- The goal of this mechanics is to ensure that atomic commands involving -- some positions visible by a client convey similar information as the client -- would get by directly observing the changes -- of the portion of server state limited to the visible positions. -- Consequently, when the visible commands are later applied -- to the client's state, the state stays consistent -- --- in sync with the server state and correctly limited by visiblity. -- There is some wiggle room both in what "in sync" and -- "visible" means and how they propagate through time. -- -- E.g., @UpdDisplaceActor@ in a black room between two enemy actors, -- with only one actor carrying a 0-radius light would not be -- distinguishable by looking at the state (or the screen) from @UpdMoveActor@ -- of the illuminated actor, hence such @UpdDisplaceActor@ should not be -- observable, but @UpdMoveActor@ in similar cotext would be -- (or the former should be perceived as the latter). -- However, to simplify, we assign as strict visibility -- requirements to @UpdMoveActor@ as to @UpdDisplaceActor@ and fall back -- to @UpdSpotActor@ (which provides minimal information that does not -- contradict state) if the visibility is lower. posUpdAtomic :: MonadStateRead m => UpdAtomic -> m PosAtomic posUpdAtomic cmd = case cmd of 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 UpdSpotItemBag c _ _ -> singleContainer c UpdLoseItemBag 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 -> doubleAid source target UpdMoveItem _ _ _ _ CSha -> error $ "" `showFailure` cmd -- shared stash is private UpdMoveItem _ _ _ CSha _ -> error $ "" `showFailure` cmd UpdMoveItem _ _ aid _ _ -> singleAid aid UpdRefillHP aid _ -> singleAid aid UpdRefillCalm aid _ -> singleAid aid UpdTrajectory aid _ _ -> singleAid aid UpdQuitFaction{} -> return PosAll UpdLeadFaction fid _ _ -> return $ PosFidAndSer Nothing fid UpdDiplFaction{} -> return PosAll UpdTacticFaction fid _ _ -> return $! PosFidAndSer Nothing fid UpdAutoFaction{} -> return PosAll UpdRecordKill aid _ _ -> singleAid aid UpdAlterTile lid p _ _ -> return $! PosSight lid [p] UpdAlterExplorable{} -> return PosAll -- Can't have @PosSight@, because we'd end up with many accessible -- unknown tiles, but the game reporting 'all seen'. UpdAlterGold{} -> return PosAll UpdSearchTile aid p _ -> do b <- getsState $ getActorBody aid return $! PosFidAndSight [bfid b] (blid b) [bpos b, p] UpdHideTile aid p _ -> do b <- getsState $ getActorBody aid return $! PosFidAndSight [bfid b] (blid b) [bpos b, p] UpdSpotTile lid ts -> do let ps = map fst ts return $! PosSight lid ps UpdLoseTile lid ts -> do let ps = map fst ts return $! PosSight lid ps 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 UpdUnAgeGame _ -> return PosAll UpdDiscover c _ _ _ -> singleContainer c UpdCover c _ _ _ -> singleContainer c UpdDiscoverKind c _ _ -> singleContainer c UpdCoverKind c _ _ -> singleContainer c UpdDiscoverAspect c _ _ -> singleContainer c UpdCoverAspect c _ _ -> singleContainer c UpdDiscoverServer{} -> return PosSer UpdCoverServer{} -> return PosSer UpdPerception{} -> return PosNone UpdRestart fid _ _ _ _ -> return $! PosFid fid UpdRestartServer _ -> return PosSer UpdResume _ _ -> return PosNone UpdResumeServer _ -> return PosSer UpdKillExit fid -> return $! PosFid fid UpdWriteSave -> return PosAll -- | Produce the positions where the atomic special effect takes place. posSfxAtomic :: MonadStateRead m => SfxAtomic -> m PosAtomic posSfxAtomic cmd = case cmd of SfxStrike _ _ _ CSha -> return PosNone -- shared stash is private SfxStrike _ target _ _ -> singleAid target SfxRecoil _ _ _ CSha -> return PosNone -- shared stash is private SfxRecoil _ target _ _ -> singleAid target SfxSteal _ _ _ CSha -> return PosNone -- shared stash is private SfxSteal _ target _ _ -> singleAid target SfxRelease _ _ _ CSha -> return PosNone -- shared stash is private SfxRelease _ target _ _ -> singleAid target SfxProject aid _ cstore -> singleContainer $ CActor aid cstore SfxReceive aid _ cstore -> singleContainer $ CActor aid cstore SfxApply aid _ cstore -> singleContainer $ CActor aid cstore SfxCheck aid _ cstore -> singleContainer $ CActor aid cstore SfxTrigger aid p -> do body <- getsState $ getActorBody aid if bproj body then return $! PosSight (blid body) [bpos body, p] else return $! PosFidAndSight [bfid body] (blid body) [bpos body, p] SfxShun aid p -> do body <- getsState $ getActorBody aid if bproj body then return $! PosSight (blid body) [bpos body, p] else return $! PosFidAndSight [bfid body] (blid body) [bpos body, p] SfxEffect _ aid _ _ -> singleAid aid -- sometimes we don't see source, OK SfxMsgFid fid _ -> return $! PosFid fid SfxSortSlots -> return PosAll SfxCollideTile 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] singleAid :: MonadStateRead m => ActorId -> m PosAtomic singleAid aid = do body <- getsState $ getActorBody aid return $! posProjBody body doubleAid :: MonadStateRead m => ActorId -> ActorId -> m PosAtomic doubleAid source target = do sb <- getsState $ getActorBody source tb <- getsState $ getActorBody target -- No @PosFidAndSight@ instead of @PosSight@, because both positions -- need to be seen to have the enemy actor in client's state. return $! assert (blid sb == blid tb) $ PosSight (blid sb) [bpos sb, bpos tb] 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 _) = singleAid aid singleContainer (CTrunk fid lid p) = return $! PosFidAndSight [fid] lid [p] -- | Decompose an atomic action that is outside a client's visiblity. -- The decomposed actions give less information that the original command, -- but some of them may fall within the visibility range of the client. -- The original action may give more information than even the total sum -- of all actions it's broken into. E.g., @UpdMoveActor@ -- informs about the continued existence of the actor between -- moves vs popping out of existence and then back in. -- -- This is computed in server's @State@ from before performing the command. breakUpdAtomic :: MonadStateRead m => UpdAtomic -> m [UpdAtomic] breakUpdAtomic cmd = case cmd of UpdMoveActor aid fromP toP -> do -- We assume other factions don't see leaders and we know the actor's -- faction always sees the atomic command, 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 $ getCarriedAssocsAndTrunk b return [ UpdLoseActor aid b ais , UpdSpotActor aid b {bpos = toP, boldpos = Just fromP} ais ] UpdDisplaceActor source target -> do sb <- getsState $ getActorBody source sais <- getsState $ getCarriedAssocsAndTrunk sb tb <- getsState $ getActorBody target tais <- getsState $ getCarriedAssocsAndTrunk 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 ] _ -> return [] -- | Given the client, its 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` totalSmelled per) ps || knowEvents PosFid fid2 -> fid == fid2 PosFidAndSer _ fid2 -> fid == fid2 PosSer -> False PosAll -> True PosNone -> error $ "no position possible" `showFailure` fid -- | Determine whether the server would see a command that has -- the given visibilty conditions. seenAtomicSer :: PosAtomic -> Bool seenAtomicSer posAtomic = case posAtomic of PosFid _ -> False PosNone -> error $ "no position possible" `showFailure` posAtomic _ -> True LambdaHack-0.8.3.0/Game/LambdaHack/Content/0000755000000000000000000000000013315545734016261 5ustar0000000000000000LambdaHack-0.8.3.0/Game/LambdaHack/Content/CaveKind.hs0000644000000000000000000001652413315545734020311 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} -- | The type of cave kinds. module Game.LambdaHack.Content.CaveKind ( CaveKind(..), makeData #ifdef EXPOSE_INTERNAL -- * Internal operations , validateSingle, validateAll #endif ) where import Prelude () import Game.LambdaHack.Common.Prelude import Control.DeepSeq import qualified Data.Text as T import GHC.Generics (Generic) import Game.LambdaHack.Common.ContentData 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 (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; for merging , 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 may be void , cminStairDist :: Int -- ^ minimal distance between stairs , cextraStairs :: Dice.Dice -- ^ extra stairs on top of from above , cdoorChance :: Chance -- ^ the chance of a door in an opening , copenChance :: Chance -- ^ if there's a door, is it open? , chidden :: Int -- ^ if not open, hidden one in n times , cactorCoeff :: Int -- ^ the lower, the more monsters spawn , cactorFreq :: Freqs ItemKind -- ^ actor groups to consider , citemNum :: Dice.Dice -- ^ number of initial items in the cave , citemFreq :: Freqs ItemKind -- ^ item groups to consider , 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 , cescapeGroup :: Maybe (GroupName PlaceKind) -- ^ escape, if any , cstairFreq :: Freqs PlaceKind -- ^ place groups to consider for stairs; in this case the rarity -- of items in the group does not affect group choice , cdesc :: Text -- ^ full cave description } deriving (Show, Generic) -- No Eq and Ord to make extending logically sound instance NFData CaveKind -- | Catch caves with not enough space for all the places. Check the size -- of the cave descriptions to make sure they fit on screen. Etc. validateSingle :: CaveKind -> [Text] validateSingle CaveKind{..} = let (minGridX, minGridY) = Dice.minDiceXY cgrid (maxGridX, maxGridY) = Dice.maxDiceXY cgrid (minMinSizeX, minMinSizeY) = Dice.minDiceXY cminPlaceSize (maxMinSizeX, maxMinSizeY) = Dice.maxDiceXY cminPlaceSize (minMaxSizeX, minMaxSizeY) = Dice.minDiceXY cmaxPlaceSize xborder = if couterFenceTile /= "basic outer fence" then 2 else 0 yborder = if 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 ] ++ [ "minGridX < 1" | minGridX < 1 ] ++ [ "minGridY < 1" | minGridY < 1 ] ++ [ "minMinSizeX < 1" | minMinSizeX < 1 ] ++ [ "minMinSizeY < 1" | minMinSizeY < 1 ] ++ [ "minMaxSizeX < maxMinSizeX" | minMaxSizeX < maxMinSizeX ] ++ [ "minMaxSizeY < maxMinSizeY" | minMaxSizeY < maxMinSizeY ] ++ [ "cxsize too small" | maxGridX * (maxMinSizeX - 4) + xborder >= cxsize ] ++ [ "cysize too small" | maxGridY * maxMinSizeY + yborder >= cysize ] ++ [ "cextraStairs < 0" | Dice.minDice cextraStairs < 0 ] ++ [ "chidden < 0" | chidden < 0 ] ++ [ "cactorCoeff < 0" | cactorCoeff < 0 ] ++ [ "citemNum < 0" | Dice.minDice citemNum < 0 ] -- | Validate all cave kinds. -- Note that names don't have to be unique: we can have several variants -- of a cave with a given name. validateAll :: ContentData ItemKind -> ContentData PlaceKind -> ContentData TileKind -> [CaveKind] -> ContentData CaveKind -> [Text] validateAll coitem coplace cotile content cocave = let missingActorFreq = filter (not . omemberGroup coitem) $ concatMap (map fst . cactorFreq) content missingItemFreq = filter (not . omemberGroup coitem) $ concatMap (map fst . citemFreq) content missingPlaceFreq = filter (not . omemberGroup coplace) $ concatMap (map fst . cplaceFreq) content missingEscapeGroup = filter (not . omemberGroup coplace) $ mapMaybe cescapeGroup content missingStairFreq = filter (not . omemberGroup coplace) $ concatMap (map fst . cstairFreq) content tileGroupFuns = [ cdefTile, cdarkCorTile, clitCorTile, cfillerTile , couterFenceTile, clegendDarkTile, clegendLitTile ] g kind = map (\f -> f kind) tileGroupFuns missingTileFreq = filter (not . omemberGroup cotile) $ concatMap g content in [ "cactorFreq item groups not in content:" <+> tshow missingActorFreq | not $ null missingActorFreq ] ++ [ "citemFreq item groups not in content:" <+> tshow missingItemFreq | not $ null missingItemFreq ] ++ [ "cplaceFreq place groups not in content:" <+> tshow missingPlaceFreq | not $ null missingPlaceFreq ] ++ [ "cescapeGroup place groups not in content:" <+> tshow missingEscapeGroup | not $ null missingEscapeGroup ] ++ [ "cstairFreq place groups not in content:" <+> tshow missingStairFreq | not $ null missingStairFreq ] ++ [ "tile groups not in content:" <+> tshow missingTileFreq | not $ null missingTileFreq ] ++ [ "no cave defined for \"default random\"" | not $ omemberGroup cocave "default random" ] makeData :: ContentData ItemKind -> ContentData PlaceKind -> ContentData TileKind -> [CaveKind] -> ContentData CaveKind makeData coitem coplace cotile = makeContentData "CaveKind" cname cfreq validateSingle (validateAll coitem coplace cotile) LambdaHack-0.8.3.0/Game/LambdaHack/Content/ModeKind.hs0000644000000000000000000002146313315545734020315 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} -- | The type of kinds of game modes. module Game.LambdaHack.Content.ModeKind ( ModeKind(..), makeData , Caves, Roster(..), Outcome(..) , HiCondPoly, HiSummand, HiPolynomial, HiIndeterminant(..) , Player(..), LeaderMode(..), AutoLeader(..) , nameOfHorrorFact #ifdef EXPOSE_INTERNAL -- * Internal operations , validateSingle, validateAll , validateSingleRoster, validateSinglePlayer, hardwiredModeGroups #endif ) where import Prelude () import Game.LambdaHack.Common.Prelude import Control.DeepSeq import Data.Binary import qualified Data.EnumMap.Strict as EM import qualified Data.IntMap.Strict as IM import qualified Data.Text as T import GHC.Generics (Generic) import Game.LambdaHack.Common.Ability import Game.LambdaHack.Common.ContentData import qualified Game.LambdaHack.Common.Dice as Dice import Game.LambdaHack.Common.Misc import Game.LambdaHack.Content.CaveKind (CaveKind) import Game.LambdaHack.Content.ItemKind (ItemKind) -- | Game mode specification. data ModeKind = ModeKind { msymbol :: Char -- ^ a symbol , 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, Generic) instance NFData ModeKind -- | 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) -- | The specification of players for the game mode. data Roster = Roster { rosterList :: [(Player, [(Int, Dice.Dice, GroupName ItemKind)])] -- ^ players in the particular team and levels, numbers and groups -- of their initial members , rosterEnemy :: [(Text, Text)] -- ^ the initial enmity matrix , rosterAlly :: [(Text, Text)] -- ^ the initial aliance matrix } deriving (Show, Generic) instance NFData Roster -- | 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 instance NFData Outcome -- | Conditional polynomial representing score calculation for this player. type HiCondPoly = [HiSummand] type HiSummand = (HiPolynomial, [Outcome]) type HiPolynomial = [(HiIndeterminant, Double)] data HiIndeterminant = HiConst | HiLoot | HiBlitz | HiSurvival | HiKill | HiLoss deriving (Show, Eq, Ord, Generic) instance Binary HiIndeterminant instance NFData HiIndeterminant -- | Properties of a particular player. data Player = Player { fname :: Text -- ^ name of the player , fgroups :: [GroupName ItemKind] -- ^ names of actor groups that may naturally -- fall under player's control, e.g., upon -- spawning or summoning , 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 , fhasGender :: Bool -- ^ whether actors have gender , ftactic :: Tactic -- ^ non-leaders behave according to this -- tactic; can be changed during the game , 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, Generic) instance Binary Player instance NFData Player -- | 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 instance NFData 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 -- ^ client is discouraged from leader switching (e.g., because -- non-leader actors have the same skills as leader); -- 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 expected to do more, -- because it's advantageous for that kind of a faction } deriving (Show, Eq, Ord, Generic) instance Binary AutoLeader instance NFData AutoLeader nameOfHorrorFact :: GroupName ItemKind nameOfHorrorFact = toGroupName "horror" -- | Catch invalid game mode kind definitions. validateSingle :: ModeKind -> [Text] validateSingle ModeKind{..} = [ "mname longer than 20" | T.length mname > 20 ] ++ validateSingleRoster mcaves mroster -- | Checks, in particular, that there is at least one faction with fneverEmpty -- or the game would get stuck as soon as the dungeon is devoid of actors. validateSingleRoster :: Caves -> Roster -> [Text] validateSingleRoster caves Roster{..} = [ "no player keeps the dungeon alive" | all (not . fneverEmpty . fst) rosterList ] ++ concatMap (validateSinglePlayer . fst) rosterList ++ let checkPl field pl = [ pl <+> "is not a player name in" <+> field | all ((/= pl) . fname . fst) 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 ++ let f (_, l) = concatMap g l g i3@(ln, _, _) = if ln `elem` IM.keys caves then [] else ["initial actor levels not among caves:" <+> tshow i3] in concatMap f rosterList validateSinglePlayer :: Player -> [Text] validateSinglePlayer Player{..} = [ "fname empty:" <+> fname | T.null fname ] ++ [ "no UI client, but UI leader:" <+> fname | not fhasUI && case fleaderMode of LeaderUI _ -> True _ -> False ] ++ [ "fskillsOther not negative:" <+> fname | any (>= 0) $ EM.elems fskillsOther ] -- | Validate game mode kinds together. validateAll :: ContentData CaveKind -> ContentData ItemKind -> [ModeKind] -> ContentData ModeKind -> [Text] validateAll cocave coitem content comode = let missingCave = filter (not . omemberGroup cocave) $ concatMap (IM.elems . mcaves) content f Roster{rosterList} = concatMap (\(p, l) -> delete nameOfHorrorFact (fgroups p) ++ map (\(_, _, grp) -> grp) l) rosterList missingRosterItems = filter (not . omemberGroup coitem) $ concatMap (f . mroster) content hardwiredAbsent = filter (not . omemberGroup comode) hardwiredModeGroups in [ "cave groups not in content:" <+> tshow missingCave | not $ null missingCave ] ++ [ "roster item groups not in content:" <+> tshow missingRosterItems | not $ null missingRosterItems ] ++ [ "Hardwired groups not in content:" <+> tshow hardwiredAbsent | not $ null hardwiredAbsent ] hardwiredModeGroups :: [GroupName ModeKind] hardwiredModeGroups = [ "campaign scenario", "starting", "starting JS" ] makeData :: ContentData CaveKind -> ContentData ItemKind -> [ModeKind] -> ContentData ModeKind makeData cocave coitem = makeContentData "ModeKind" mname mfreq validateSingle (validateAll cocave coitem) LambdaHack-0.8.3.0/Game/LambdaHack/Content/PlaceKind.hs0000644000000000000000000000631713315545734020456 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} -- | The type of kinds of rooms, halls and passages. module Game.LambdaHack.Content.PlaceKind ( PlaceKind(..), makeData , Cover(..), Fence(..) #ifdef EXPOSE_INTERNAL -- * Internal operations , validateSingle, validateAll #endif ) where import Prelude () import Game.LambdaHack.Common.Prelude import qualified Data.Text as T import Control.DeepSeq import Game.LambdaHack.Common.ContentData import Game.LambdaHack.Common.Misc import Game.LambdaHack.Content.TileKind (TileKind) import GHC.Generics (Generic) -- | 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, Generic) -- No Eq and Ord to make extending logically sound instance NFData PlaceKind -- | A method of filling the whole area (except for CVerbatim and CMirror, -- which are just placed in the middle of the area) by transforming -- a given corner. data Cover = CAlternate -- ^ reflect every other corner, overlapping 1 row and column | CStretch -- ^ fill symmetrically 4 corners and stretch their borders | CReflect -- ^ tile separately and symmetrically quarters of the place | CVerbatim -- ^ just build the given interior, without filling the area | CMirror -- ^ build the given interior in one of 4 mirrored variants deriving (Show, Eq, Generic) instance NFData Cover -- | 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, Generic) instance NFData Fence -- | Catch invalid place kind definitions. In particular, verify that -- the top-left corner map is rectangular and not empty. validateSingle :: PlaceKind -> [Text] validateSingle 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. validateAll :: ContentData TileKind -> [PlaceKind] -> ContentData PlaceKind -> [Text] validateAll cotile content _ = let missingOverride = filter (not . omemberGroup cotile) $ concatMap (map snd . poverride) content in [ "poverride tile groups not in content:" <+> tshow missingOverride | not $ null missingOverride ] makeData :: ContentData TileKind -> [PlaceKind] -> ContentData PlaceKind makeData cotile = makeContentData "PlaceKind" pname pfreq validateSingle (validateAll cotile) LambdaHack-0.8.3.0/Game/LambdaHack/Content/RuleKind.hs0000644000000000000000000000531613315545734020337 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} -- | The type of game rule sets and assorted game data. module Game.LambdaHack.Content.RuleKind ( RuleKind(..), makeData #ifdef EXPOSE_INTERNAL -- * Internal operations , validateSingle, validateAll #endif ) where import Prelude () import Game.LambdaHack.Common.Prelude import Control.DeepSeq import qualified Data.Text as T import Data.Version import GHC.Generics (Generic) import Game.LambdaHack.Common.ContentData -- | The type of game rule sets and assorted game data. -- -- In principle, it's possible to have many rule sets -- and switch between them during a game session or even a single game. data RuleKind = RuleKind { rsymbol :: Char -- ^ a symbol , rname :: Text -- ^ short description , rfreq :: Freqs RuleKind -- ^ frequency within groups , rtitle :: Text -- ^ title of the game (not lib) , rfontDir :: FilePath -- ^ font directory for the game (not lib) , rexeVersion :: Version -- ^ version of the game , rcfgUIName :: FilePath -- ^ name of the UI config file , rcfgUIDefault :: String -- ^ the default UI settings config file , rmainMenuArt :: Text -- ^ the ASCII art for the main menu , rintroScreen :: [String] -- ^ the intro screen (first help screen) text , rfirstDeathEnds :: Bool -- ^ whether first non-spawner actor death -- ends the game , rwriteSaveClips :: Int -- ^ game is saved that often (not on browser) , rleadLevelClips :: Int -- ^ server switches leader level that often , rscoresFile :: FilePath -- ^ name of the scores file , rnearby :: Int -- ^ what distance between actors is 'nearby' } deriving Generic -- | A dummy instance of the 'Show' class, to satisfy general requirments -- about content. We won't don't expect to ever print out whole rule sets. instance Show RuleKind where show _ = "The game ruleset specification." instance NFData RuleKind -- | Catch invalid rule kind definitions. validateSingle :: RuleKind -> [Text] validateSingle RuleKind{rmainMenuArt} = let ts = T.lines rmainMenuArt tsNot80 = filter ((/= 80) . T.length) ts in case tsNot80 of [] -> [ "rmainMenuArt doesn't have 45 lines, but " <> tshow (length ts) | length ts /= 45] tNot80 : _ -> ["rmainMenuArt has a line with length other than 80:" <> tNot80] -- | Since we have only one rule kind, the set of rule kinds is always valid. validateAll :: [RuleKind] -> ContentData RuleKind -> [Text] validateAll _ _ = [] makeData :: [RuleKind] -> ContentData RuleKind makeData = makeContentData "RuleKind" rname rfreq validateSingle validateAll LambdaHack-0.8.3.0/Game/LambdaHack/Content/ItemKind.hs0000644000000000000000000005214113315545734020324 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} -- | The type of kinds of weapons, treasure, organs, blasts, etc. module Game.LambdaHack.Content.ItemKind ( ItemKind(..), makeData , Effect(..), DetectKind(..), TimerDice, ThrowMod(..), Feature(..) , ItemSpeedup, emptyItemSpeedup, getKindMean, speedupItem , boostItemKindList, forApplyEffect, onlyMinorEffects , filterRecharging, stripRecharging, stripOnSmash , strengthOnSmash, getDropOrgans, getToThrow, getHideAs, getEqpSlot , isEffEscape, isEffAscend, isEffEscapeOrAscend , isMelee, isTmpCondition, isBlast, isHumanTrinket , goesIntoEqp, goesIntoInv, goesIntoSha , itemTrajectory, totalRange, damageUsefulness , tmpNoLonger, tmpLess, toVelocity, toLinger , timerNone, isTimerNone, foldTimer , toOrganBad, toOrganGood, toOrganNoTimer #ifdef EXPOSE_INTERNAL -- * Internal operations , meanAspect, boostItemKind, majorEffect , validateSingle, validateAll, validateDups, validateDamage , hardwiredItemGroups #endif ) where import Prelude () import Game.LambdaHack.Common.Prelude import Control.DeepSeq import Data.Binary import qualified Data.Text as T import qualified Data.Vector as V import GHC.Generics (Generic) import qualified NLP.Miniutter.English as MU import qualified System.Random as R import Game.LambdaHack.Common.ContentData import qualified Game.LambdaHack.Common.Dice as Dice import Game.LambdaHack.Common.Flavour import qualified Game.LambdaHack.Common.ItemAspect as IA import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.Time import Game.LambdaHack.Common.Vector -- | Item properties that are fixed for a given kind of items. -- Note that this type is mutually recursive with 'Effect' and `Feature`. data ItemKind = ItemKind { isymbol :: Char -- ^ map symbol , iname :: Text -- ^ generic name; is pluralized if needed , ifreq :: Freqs ItemKind -- ^ frequency within groups , iflavour :: [Flavour] -- ^ possible flavours , icount :: Dice.Dice -- ^ created in that quantity , irarity :: Rarity -- ^ rarity on given depths , iverbHit :: MU.Part -- ^ the verb for hitting , iweight :: Int -- ^ weight in grams , idamage :: Dice.Dice -- ^ basic impact damage , iaspects :: [IA.Aspect] -- ^ affect the actor continuously , ieffects :: [Effect] -- ^ cause the effects when triggered , ifeature :: [Feature] -- ^ properties of the item , idesc :: Text -- ^ description , ikit :: [(GroupName ItemKind, CStore)] -- ^ accompanying organs and equipment } deriving (Show, Generic) -- No Eq and Ord to make extending logically sound -- | Effects of items. Can be invoked by the item wielder to affect -- another actor or the wielder himself. Many occurences in the same item -- are possible. data Effect = Burn Dice.Dice -- ^ burn with this damage | Explode (GroupName ItemKind) -- ^ explode producing this group of blasts | RefillHP Int -- ^ modify HP of the actor by this amount | RefillCalm Int -- ^ modify Calm of the actor by this amount | Dominate -- ^ change actor's allegiance | Impress -- ^ make actor susceptible to domination | Summon (GroupName ItemKind) Dice.Dice -- ^ summon the given number of actors of this group | Ascend Bool -- ^ ascend to another level of the dungeon | Escape -- ^ escape from the dungeon | Paralyze Dice.Dice -- ^ paralyze for this many game clips | InsertMove Dice.Dice -- ^ give free time to actor of this many actor turns | Teleport Dice.Dice -- ^ teleport actor across rougly this distance | CreateItem CStore (GroupName ItemKind) TimerDice -- ^ create an item of the group and insert into the store with the given -- random timer | DropItem Int Int CStore (GroupName ItemKind) -- ^ make the actor drop items of the given group from the given store; -- the first integer says how many item kinds to drop, the second, -- how many copies of each kind to drop; for non-organs, beware of -- not dropping all, or cluttering store with rubbish becomes beneficial | PolyItem -- ^ find a suitable (i.e., numerous enough) item, starting from -- the floor, and polymorph it randomly | Identify -- ^ find a suitable (i.e., not identified) item, starting from -- the floor, and identify it | Detect DetectKind Int -- ^ detect something on the map in the given radius | SendFlying ThrowMod -- ^ send an actor flying (push or pull, depending) | PushActor ThrowMod -- ^ push an actor | PullActor ThrowMod -- ^ pull an actor | DropBestWeapon -- ^ make the actor drop its best weapon | ActivateInv Char -- ^ activate all items with this symbol in inventory; space character -- means all symbols | ApplyPerfume -- ^ remove all smell on the level | OneOf [Effect] -- ^ trigger one of the effects with equal probability | OnSmash Effect -- ^ trigger the effect when item smashed (not when applied nor meleed) | Recharging Effect -- ^ this effect inactive until timeout passes | Composite [Effect] -- ^ only fire next effect if previous fully activated | Temporary Text -- ^ the item is temporary, vanishes at even void Periodic activation, -- unless Durable and not Fragile, and shows message with -- this verb at last copy activation or at each activation -- unless Durable and Fragile deriving (Show, Eq, Generic) data DetectKind = DetectAll | DetectActor | DetectItem | DetectExit | DetectHidden | DetectEmbed deriving (Show, Eq, Generic) -- | Specification of how to randomly roll a timer at item creation -- to obtain a fixed timer for the item's lifetime. data TimerDice = TimerNone | TimerGameTurn Dice.Dice | TimerActorTurn Dice.Dice deriving (Eq, 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" -- | Parameters modifying a throw of a projectile or flight of pushed actor. -- Not additive and don't start at 0. data ThrowMod = ThrowMod { throwVelocity :: Int -- ^ fly with this percentage of base throw speed , throwLinger :: Int -- ^ fly for this percentage of 2 turns } deriving (Show, Eq, Ord, Generic) -- | Features of item. Affect only the item in question, -- not the actor carrying it, and so not additive in any sense. data Feature = ELabel Text -- ^ extra label of the item; it's not pluralized | Fragile -- ^ drop and break at target tile, even if no hit | Lobable -- ^ drop at target tile, even if no hit | Durable -- ^ don't break even when hitting or applying | ToThrow ThrowMod -- ^ parameters modifying a throw | HideAs (GroupName ItemKind) -- ^ until identified, presents as this unique kind | Equipable -- ^ AI and UI flag: consider equipping (independent of -- 'EqpSlot', e.g., in case of mixed blessings) | Meleeable -- ^ AI and UI flag: consider meleeing with | Precious -- ^ AI and UI flag: don't risk identifying by use; -- also, can't throw or apply if not calm enough | Tactic Tactic -- ^ overrides actor's tactic; WIP; move? | Blast -- ^ the item is an explosion blast particle | EqpSlot IA.EqpSlot -- ^ AI and UI flag that leaks item intended use | Unique -- ^ at most one copy can ever be generated | Periodic -- ^ in eqp, triggered as often as @Timeout@ permits | MinorEffects -- ^ override: the effects on this item are considered -- minor and so not causing identification on use, -- and so this item will identify on pick-up deriving (Show, Eq, Ord, Generic) -- | Map from an item kind identifier to the mean aspect value for the kind. -- -- Significant portions of this map are unused and so intentially kept -- unevaluated. newtype ItemSpeedup = ItemSpeedup (V.Vector IA.KindMean) deriving (Show, Eq, Generic) instance NFData ItemKind instance NFData Effect instance NFData DetectKind instance NFData TimerDice instance NFData ThrowMod instance NFData Feature instance Binary Effect instance Binary DetectKind instance Binary TimerDice instance Binary ThrowMod emptyItemSpeedup :: ItemSpeedup emptyItemSpeedup = ItemSpeedup V.empty getKindMean :: ContentId ItemKind -> ItemSpeedup -> IA.KindMean getKindMean kindId (ItemSpeedup is) = is V.! contentIdIndex kindId speedupItem :: ContentData ItemKind -> ItemSpeedup speedupItem coitem = let f !kind = let kmMean = meanAspect kind kmConst = not $ IA.aspectsRandom (iaspects kind) in IA.KindMean{..} in ItemSpeedup $! omapVector coitem f meanAspect :: ItemKind -> IA.AspectRecord meanAspect kind = foldl' IA.addMeanAspect IA.emptyAspectRecord (iaspects kind) boostItemKindList :: R.StdGen -> [ItemKind] -> [ItemKind] boostItemKindList _ [] = [] boostItemKindList initialGen l = let (r, _) = R.randomR (0, length l - 1) initialGen in case splitAt r l of (pre, i : post) -> pre ++ boostItemKind i : post _ -> error $ "" `showFailure` l boostItemKind :: ItemKind -> ItemKind boostItemKind i = let mainlineLabel (label, _) = label `elem` ["common item", "curious item", "treasure"] in if any mainlineLabel (ifreq i) then i { ifreq = ("common item", 10000) : filter (not . mainlineLabel) (ifreq i) , ifeature = delete Unique $ ifeature i } else i -- | Whether the effect has a chance of exhibiting any potentially -- noticeable behaviour, except when the item is destroyed. -- We assume at least one of @OneOf@ effects must be noticeable. forApplyEffect :: Effect -> Bool forApplyEffect eff = case eff of OnSmash{} -> False Recharging eff2 -> forApplyEffect eff2 Composite effs -> any forApplyEffect effs Temporary{} -> False _ -> True majorEffect :: Effect -> Bool majorEffect eff = case eff of OnSmash{} -> False Recharging eff2 -> majorEffect eff2 Composite (eff1 : _) -> majorEffect eff1 -- the rest may never fire _ -> True onlyMinorEffects :: ItemKind -> Bool onlyMinorEffects kind = MinorEffects `elem` ifeature kind -- override || not (any majorEffect $ ieffects kind) -- exhibits no major effects isEffEscape :: Effect -> Bool isEffEscape Escape{} = True isEffEscape (OneOf l) = any isEffEscapeOrAscend l isEffEscape (Recharging eff) = isEffEscapeOrAscend eff isEffEscape (Composite l) = any isEffEscapeOrAscend l isEffEscape _ = False isEffAscend :: Effect -> Bool isEffAscend Ascend{} = True isEffAscend (OneOf l) = any isEffEscapeOrAscend l isEffAscend (Recharging eff) = isEffEscapeOrAscend eff isEffAscend (Composite l) = any isEffEscapeOrAscend l isEffAscend _ = False isEffEscapeOrAscend :: Effect -> Bool isEffEscapeOrAscend Ascend{} = True isEffEscapeOrAscend Escape{} = True isEffEscapeOrAscend (OneOf l) = any isEffEscapeOrAscend l isEffEscapeOrAscend (Recharging eff) = isEffEscapeOrAscend eff isEffEscapeOrAscend (Composite l) = any isEffEscapeOrAscend l isEffEscapeOrAscend _ = False filterRecharging :: [Effect] -> [Effect] filterRecharging 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 strengthOnSmash :: ItemKind -> [Effect] strengthOnSmash = let f (OnSmash eff) = [eff] f _ = [] in concatMap f . ieffects getDropOrgans :: ItemKind -> [GroupName ItemKind] getDropOrgans = let f (DropItem _ _ COrgan grp) = [grp] f Impress = ["impressed"] f (OneOf l) = concatMap f l f (Recharging eff) = f eff f (Composite l) = concatMap f l f _ = [] in concatMap f . ieffects getToThrow :: ItemKind -> ThrowMod getToThrow itemKind = let f (ToThrow tmod) = [tmod] f _ = [] in case concatMap f (ifeature itemKind) of [] -> ThrowMod 100 100 x : _ -> x getHideAs :: ItemKind -> Maybe (GroupName ItemKind) getHideAs itemKind = let f (HideAs grp) = [grp] f _ = [] in case concatMap f (ifeature itemKind) of [] -> Nothing x : _ -> Just x getEqpSlot :: ItemKind -> Maybe IA.EqpSlot getEqpSlot itemKind = let f (EqpSlot eqpSlot) = [eqpSlot] f _ = [] in case concatMap f (ifeature itemKind) of [] -> Nothing x : _ -> Just x isMelee :: ItemKind -> Bool isMelee itemKind = Meleeable `elem` ifeature itemKind isTmpCondition :: ItemKind -> Bool isTmpCondition itemKind = Fragile `elem` ifeature itemKind && Durable `elem` ifeature itemKind isBlast :: ItemKind -> Bool isBlast itemKind = Blast `elem` ifeature itemKind isHumanTrinket :: ItemKind -> Bool isHumanTrinket itemKind = Precious `elem` ifeature itemKind -- risk from treasure hunters && Equipable `notElem` ifeature itemKind -- can't wear goesIntoEqp :: ItemKind -> Bool goesIntoEqp itemKind = Equipable `elem` ifeature itemKind || Meleeable `elem` ifeature itemKind goesIntoInv :: ItemKind -> Bool goesIntoInv itemKind = Precious `notElem` ifeature itemKind && not (goesIntoEqp itemKind) goesIntoSha :: ItemKind -> Bool goesIntoSha itemKind = Precious `elem` ifeature itemKind && not (goesIntoEqp itemKind) itemTrajectory :: ItemKind -> [Point] -> ([Vector], (Speed, Int)) itemTrajectory itemKind path = let ThrowMod{..} = getToThrow itemKind in computeTrajectory (iweight itemKind) throwVelocity throwLinger path totalRange :: ItemKind -> Int totalRange itemKind = snd $ snd $ itemTrajectory itemKind [] damageUsefulness :: ItemKind -> Double damageUsefulness itemKind = let v = min 1000 (10 * Dice.meanDice (idamage itemKind)) in assert (v >= 0) v tmpNoLonger :: Text -> Effect tmpNoLonger name = Temporary $ "be no longer" <+> name tmpLess :: Text -> Effect tmpLess name = Temporary $ "become less" <+> name toVelocity :: Int -> Feature toVelocity n = ToThrow $ ThrowMod n 100 toLinger :: Int -> Feature toLinger n = ToThrow $ ThrowMod 100 n timerNone :: TimerDice timerNone = TimerNone isTimerNone :: TimerDice -> Bool isTimerNone tim = tim == TimerNone foldTimer :: a -> (Dice.Dice -> a) -> (Dice.Dice -> a) -> TimerDice -> a foldTimer a fgame factor tim = case tim of TimerNone -> a TimerGameTurn nDm -> fgame nDm TimerActorTurn nDm -> factor nDm toOrganBad :: GroupName ItemKind -> Dice.Dice -> Effect toOrganBad grp nDm = assert (Dice.minDice nDm > 0 `blame` "dice at organ creation should always roll above zero" `swith` (grp, nDm)) $ CreateItem COrgan grp (TimerGameTurn nDm) toOrganGood :: GroupName ItemKind -> Dice.Dice -> Effect toOrganGood grp nDm = assert (Dice.minDice nDm > 0 `blame` "dice at organ creation should always roll above zero" `swith` (grp, nDm)) $ CreateItem COrgan grp (TimerActorTurn nDm) toOrganNoTimer :: GroupName ItemKind -> Effect toOrganNoTimer grp = CreateItem COrgan grp TimerNone -- | Catch invalid item kind definitions. validateSingle :: ItemKind -> [Text] validateSingle ik@ItemKind{..} = [ "iname longer than 23" | T.length iname > 23 ] ++ [ "icount < 0" | Dice.minDice icount < 0 ] ++ validateRarity irarity ++ validateDamage idamage -- Reject duplicate Timeout, because it's not additive. ++ (let timeoutAspect :: IA.Aspect -> Bool timeoutAspect IA.Timeout{} = True timeoutAspect _ = False ts = filter timeoutAspect iaspects in ["more than one Timeout specification" | length ts > 1]) ++ (let f :: Feature -> Bool f EqpSlot{} = True f _ = False ts = filter f ifeature in [ "EqpSlot specified but not Equipable nor Meleeable" | length ts > 0 && Equipable `notElem` ifeature && Meleeable `notElem` ifeature ]) ++ ["Redundant Equipable or Meleeable" | Equipable `elem` ifeature && Meleeable `elem` ifeature] ++ (let f :: Effect -> Bool f OnSmash{} = True f _ = False in validateNotNested ieffects "OnSmash" f) -- duplicates permitted ++ (let f :: Effect -> Bool f Recharging{} = True f _ = False in validateNotNested ieffects "Recharging" f) -- duplicates permitted ++ (let f :: Effect -> Bool f Temporary{} = True f _ = False in validateOnlyOne ieffects "Temporary" f) -- may be duplicated if nested ++ (let f :: Feature -> Bool f ELabel{} = True f _ = False ts = filter f ifeature in ["more than one ELabel specification" | length ts > 1]) ++ (let f :: Feature -> Bool f ToThrow{} = True f _ = False ts = filter f ifeature in ["more than one ToThrow specification" | length ts > 1]) ++ (let f :: Feature -> Bool f HideAs{} = True f _ = False ts = filter f ifeature in ["more than one HideAs specification" | length ts > 1]) ++ (let f :: Feature -> Bool f Tactic{} = True f _ = False ts = filter f ifeature in ["more than one Tactic specification" | length ts > 1]) ++ concatMap (validateDups ik) [ Fragile, Lobable, Durable, Equipable, Meleeable, Precious, Blast , Unique, Periodic] -- We only check there are no duplicates at top level. If it may be nested, -- it may presumably be duplicated inside the nesting as well. validateOnlyOne :: [Effect] -> Text -> (Effect -> Bool) -> [Text] validateOnlyOne effs t f = let ts = filter f effs in ["more than one" <+> t <+> "specification" | length ts > 1] -- We check it's not nested one nor more levels. validateNotNested :: [Effect] -> Text -> (Effect -> Bool) -> [Text] validateNotNested effs t f = let g (OneOf l) = any f l || any g l g (OnSmash effect) = f effect || g effect g (Recharging effect) = f effect || g effect g (Composite l) = any f l || any g l g _ = False ts = filter g effs in [ "effect" <+> t <+> "should be specified at top level, not nested" | length ts > 0 ] validateDups :: ItemKind -> Feature -> [Text] validateDups ItemKind{..} feat = let ts = filter (== feat) ifeature in ["more than one" <+> tshow feat <+> "specification" | length ts > 1] validateDamage :: Dice.Dice -> [Text] validateDamage dice = [ "potentially negative dice:" <+> tshow dice | Dice.minDice dice < 0] -- | Validate all item kinds. validateAll :: [ItemKind] -> ContentData ItemKind -> [Text] validateAll content coitem = let missingKitGroups = [ cgroup | k <- content , (cgroup, _) <- ikit k , not $ omemberGroup coitem cgroup ] f :: Feature -> Bool f HideAs{} = True f _ = False wrongHideAsGroups = [ cgroup | k <- content , let (cgroup, notSingleton) = case find f (ifeature k) of Just (HideAs grp) | not $ oisSingletonGroup coitem grp -> (grp, True) _ -> (undefined, False) , notSingleton ] g :: Effect -> Maybe (GroupName ItemKind) g (Explode grp) = Just grp g (Summon grp _) = Just grp g (CreateItem _ grp _) = Just grp g (DropItem _ _ _ grp) = Just grp g _ = Nothing missingEffectGroups = [ (iname k, absGroups) | k <- content , let grps = mapMaybe g $ ieffects k absGroups = filter (not . omemberGroup coitem) grps , not $ null absGroups ] missingHardwiredGroups = filter (not . omemberGroup coitem) hardwiredItemGroups in [ "no ikit groups in content:" <+> tshow missingKitGroups | not $ null missingKitGroups ] ++ [ "HideAs groups not singletons:" <+> tshow wrongHideAsGroups | not $ null wrongHideAsGroups ] ++ [ "mentioned groups not in content:" <+> tshow missingEffectGroups | not $ null missingEffectGroups ] ++ [ "hardwired groups not in content:" <+> tshow missingHardwiredGroups | not $ null missingHardwiredGroups ] hardwiredItemGroups :: [GroupName ItemKind] hardwiredItemGroups = -- From Preferences.hs: ["condition", "common item"] -- the others are optional: -- "curious item", "treasure", "any scroll", "any vial", -- "potion", "explosive", "any jewelry" -- Assorted: ++ ["bonus HP", "currency", "impressed", "mobile"] makeData :: [ItemKind] -> ContentData ItemKind makeData = makeContentData "ItemKind" iname ifreq validateSingle validateAll LambdaHack-0.8.3.0/Game/LambdaHack/Content/TileKind.hs0000644000000000000000000003050713315545734020325 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} -- | The type of kinds of terrain tiles. module Game.LambdaHack.Content.TileKind ( TileKind(..), makeData , Feature(..), TileSpeedup(..), Tab(..) , emptyTileSpeedup, emptyTab , actionFeatures, isUknownSpace, unknownId , isSuspectKind, isOpenableKind, isClosableKind , talterForStairs, floorSymbol #ifdef EXPOSE_INTERNAL -- * Internal operations , validateSingle, validateAll , validateDups, hardwiredTileGroups #endif ) where import Prelude () import Game.LambdaHack.Common.Prelude import Control.DeepSeq import Data.Binary import qualified Data.Char as Char import Data.Hashable import qualified Data.IntSet as IS import qualified Data.Text as T import qualified Data.Vector.Unboxed as U import GHC.Generics (Generic) import Game.LambdaHack.Common.Color import Game.LambdaHack.Common.ContentData import Game.LambdaHack.Common.Misc import Game.LambdaHack.Content.ItemKind (ItemKind) -- | The type of kinds of terrain tiles. See @Tile.hs@ for explanation -- of the absence of a corresponding type @Tile@ that would hold -- particular concrete tiles in the dungeon. -- Note that tile names (and any other content names) should not be plural -- (that would lead to "a stairs"), so "road with cobblestones" is fine, -- but "granite cobblestones" is wrong. -- -- Tile kind for unknown space has the minimal @ContentId@ index. -- The @talter@ for unknown space is @1@ and no other tile kind has that value. data TileKind = TileKind { tsymbol :: Char -- ^ map symbol , tname :: Text -- ^ short description , tfreq :: Freqs TileKind -- ^ frequency within groups , tcolor :: Color -- ^ map color , tcolor2 :: Color -- ^ map color when not in FOV , talter :: Word8 -- ^ minimal skill needed to alter the tile , tfeature :: [Feature] -- ^ properties } deriving (Show, Generic) -- No Eq and Ord to make extending logically sound instance NFData TileKind -- | All possible terrain tile features. data Feature = Embed (GroupName ItemKind) -- ^ initially an item of this group is embedded; -- we assume the item has effects and is supposed to be triggered | OpenTo (GroupName TileKind) -- ^ goes from a closed to (randomly closed or) open tile when altered | CloseTo (GroupName TileKind) -- ^ goes from an open to (randomly opened or) closed tile when altered | ChangeTo (GroupName TileKind) -- ^ alters tile, but does not change walkability | HideAs (GroupName TileKind) -- ^ when hidden, looks as the unique tile of the group | BuildAs (GroupName TileKind) -- ^ when generating, may be transformed to the unique tile of the group | RevealAs (GroupName TileKind) -- ^ when generating in opening, can be revealed to belong to the group | ObscureAs (GroupName TileKind) -- ^ when generating in solid wall, can be revealed to belong to the group | Walkable -- ^ actors can walk through | Clear -- ^ actors can see through | Dark -- ^ is not lit with an ambient light | OftenItem -- ^ initial items often generated there | OftenActor -- ^ initial actors often generated there | NoItem -- ^ no items ever generated there | NoActor -- ^ no actors ever generated there | ConsideredByAI -- ^ even if otherwise uninteresting, taken into -- account for triggering by AI | Trail -- ^ used for visible trails throughout the level | Spice -- ^ in place normal legend and in override, -- don't roll a tile kind only once per place, -- but roll for each position; one non-spicy and -- at most one spicy is rolled per place and then -- one of the two is rolled for each position deriving (Show, Eq, Ord, Generic) instance Binary Feature instance Hashable Feature instance NFData Feature -- | A lot of tabulated maps from tile kind identifier to a property -- of the tile kind. data TileSpeedup = TileSpeedup { isClearTab :: Tab Bool , isLitTab :: Tab Bool , isWalkableTab :: Tab Bool , isDoorTab :: Tab Bool , isChangableTab :: Tab Bool , isSuspectTab :: Tab Bool , isHideAsTab :: Tab Bool , consideredByAITab :: Tab Bool , isOftenItemTab :: Tab Bool , isOftenActorTab :: Tab Bool , isNoItemTab :: Tab Bool , isNoActorTab :: Tab Bool , isEasyOpenTab :: Tab Bool , alterMinSkillTab :: Tab Word8 , alterMinWalkTab :: Tab Word8 } deriving Generic instance NFData TileSpeedup -- Vectors of booleans can be slower than arrays, because they are not packed, -- but with growing cache sizes they may as well turn out faster at some point. -- The advantage of vectors are exposed internals, in particular unsafe -- indexing. Also, in JS, bool arrays are obviously not packed. -- | A map morally indexed by @ContentId TileKind@. newtype Tab a = Tab (U.Vector a) deriving Generic instance NFData (Tab a) emptyTileSpeedup :: TileSpeedup emptyTileSpeedup = TileSpeedup emptyTab emptyTab emptyTab emptyTab emptyTab emptyTab emptyTab emptyTab emptyTab emptyTab emptyTab emptyTab emptyTab emptyTab emptyTab emptyTab :: U.Unbox a => Tab a emptyTab = Tab $! U.empty -- | Validate a single tile kind. validateSingle :: TileKind -> [Text] validateSingle t@TileKind{..} = [ "suspect tile is walkable" | Walkable `elem` tfeature && isSuspectKind t ] ++ [ "openable tile is open" | Walkable `elem` tfeature && isOpenableKind t ] ++ [ "closable tile is closed" | Walkable `notElem` tfeature && isClosableKind t ] ++ [ "walkable tile is considered for triggering by AI" | Walkable `elem` tfeature && ConsideredByAI `elem` tfeature ] ++ [ "trail tile not walkable" | Walkable `notElem` tfeature && Trail `elem` tfeature ] ++ [ "OftenItem and NoItem on a tile" | OftenItem `elem` tfeature && NoItem `elem` tfeature ] ++ [ "OftenActor and NoActor on a tile" | OftenItem `elem` tfeature && NoItem `elem` tfeature ] ++ (let f :: Feature -> Bool f OpenTo{} = True f CloseTo{} = True f ChangeTo{} = True f _ = False ts = filter f tfeature in [ "more than one OpenTo, CloseTo and ChangeTo specification" | length ts > 1 ]) ++ (let f :: Feature -> Bool f HideAs{} = True f _ = False ts = filter f tfeature in ["more than one HideAs specification" | length ts > 1]) ++ (let f :: Feature -> Bool f BuildAs{} = True f _ = False ts = filter f tfeature in ["more than one BuildAs specification" | length ts > 1]) ++ concatMap (validateDups t) [ Walkable, Clear, Dark, OftenItem, OftenActor, NoItem, NoActor , ConsideredByAI, Trail, Spice ] validateDups :: TileKind -> Feature -> [Text] validateDups TileKind{..} feat = let ts = filter (== feat) tfeature in ["more than one" <+> tshow feat <+> "specification" | length ts > 1] -- | Validate all tile kinds. -- -- We don't check it any more, but if tiles look the same on the map -- (symbol and color), their substantial features should be the same, too, -- unless there is a good reason they shouldn't. Otherwise the player has -- to inspect manually all the tiles with this look to see if any is special. -- This tends to be tedious. Note that tiles may freely differ wrt text blurb, -- dungeon generation rules, AI preferences, etc., whithout causing the tedium. validateAll :: ContentData ItemKind -> [TileKind] -> ContentData TileKind -> [Text] validateAll coitem content cotile = let g :: Feature -> Maybe (GroupName TileKind) g (OpenTo grp) = Just grp g (CloseTo grp) = Just grp g (ChangeTo grp) = Just grp g (HideAs grp) = Just grp g (BuildAs grp) = Just grp g (RevealAs grp) = Just grp g (ObscureAs grp) = Just grp g _ = Nothing missingTileGroups = [ (tname k, absGroups) | k <- content , let grps = mapMaybe g $ tfeature k absGroups = filter (not . omemberGroup cotile) grps , not $ null absGroups ] h :: Feature -> Maybe (GroupName ItemKind) h (Embed grp) = Just grp h _ = Nothing missingItemGroups = [ (tname k, absGroups) | k <- content , let grps = mapMaybe h $ tfeature k absGroups = filter (not . omemberGroup coitem) grps , not $ null absGroups ] missingHardwiredGroups = filter (not . omemberGroup cotile) hardwiredTileGroups in [ "first tile should be the unknown one" | talter (head content) /= 1 || tname (head content) /= "unknown space" ] ++ [ "only unknown tile may have talter 1" | any ((== 1) . talter) $ tail content ] ++ [ "mentioned tile groups not in content:" <+> tshow missingTileGroups | not $ null missingTileGroups ] ++ [ "embedded item groups not in content:" <+> tshow missingItemGroups | not $ null missingItemGroups ] ++ [ "hardwired groups not in content:" <+> tshow missingHardwiredGroups | not $ null missingHardwiredGroups ] hardwiredTileGroups :: [GroupName TileKind] hardwiredTileGroups = [ "unknown space", "legendLit", "legendDark", "unknown outer fence" , "basic outer fence", "stair terminal" ] -- | Features of tiles that differentiate them substantially from one another. -- The intention is the player can easily tell such tiles apart by their -- behaviour and only looking at the map, not tile name nor description. -- 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 stripLight grp = maybe grp toGroupName $ maybe (T.stripSuffix "Dark" $ tshow grp) Just $ T.stripSuffix "Lit" $ tshow grp f feat = case feat of Embed{} -> Just feat OpenTo grp -> Just $ OpenTo $ stripLight grp CloseTo grp -> Just $ CloseTo $ stripLight grp ChangeTo grp -> Just $ ChangeTo $ stripLight grp Walkable -> Just feat Clear -> Just feat HideAs{} -> Nothing BuildAs{} -> Nothing RevealAs{} -> if markSuspect then Just feat else Nothing ObscureAs{} -> if markSuspect then Just feat else Nothing Dark -> Nothing -- not important any longer, after FOV computed OftenItem -> Nothing OftenActor -> Nothing NoItem -> Nothing NoActor -> Nothing ConsideredByAI -> Nothing Trail -> Just feat -- doesn't affect tile behaviour, but important Spice -> Nothing in IS.fromList $ map hash $ mapMaybe f $ tfeature t isUknownSpace :: ContentId TileKind -> Bool {-# INLINE isUknownSpace #-} isUknownSpace tt = ContentId 0 == tt unknownId :: ContentId TileKind {-# INLINE unknownId #-} unknownId = ContentId 0 isSuspectKind :: TileKind -> Bool isSuspectKind t = let getTo RevealAs{} = True getTo ObscureAs{} = True getTo _ = False in any getTo $ tfeature t isOpenableKind ::TileKind -> Bool isOpenableKind t = let getTo OpenTo{} = True getTo _ = False in any getTo $ tfeature t isClosableKind :: TileKind -> Bool isClosableKind t = let getTo CloseTo{} = True getTo _ = False in any getTo $ tfeature t talterForStairs :: Word8 talterForStairs = 3 floorSymbol :: Char.Char floorSymbol = Char.chr 183 -- Alter skill schema: -- 0 can be altered by everybody (escape) -- 1 unknown only -- 2 openable and suspect -- 3 stairs -- 4 closable -- 5 changeable (e.g., caches) -- 10 weak obstructions -- 50 considerable obstructions -- 100 walls -- maxBound impenetrable walls, etc., can never be altered makeData :: ContentData ItemKind -> [TileKind] -> ContentData TileKind makeData coitem = makeContentData "TileKind" tname tfreq validateSingle (validateAll coitem) LambdaHack-0.8.3.0/Game/LambdaHack/Client/0000755000000000000000000000000013315545734016065 5ustar0000000000000000LambdaHack-0.8.3.0/Game/LambdaHack/Client/LoopM.hs0000644000000000000000000001036413315545734017453 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} -- | The main loop of the client, processing human and computer player -- moves turn by turn. module Game.LambdaHack.Client.LoopM ( MonadClientReadResponse(..) , loopCli #ifdef EXPOSE_INTERNAL -- * Internal operations , initAI, initUI #endif ) where import Prelude () import Game.LambdaHack.Common.Prelude import Game.LambdaHack.Atomic import Game.LambdaHack.Client.ClientOptions import Game.LambdaHack.Client.HandleAtomicM import Game.LambdaHack.Client.HandleResponseM import Game.LambdaHack.Client.MonadClient import Game.LambdaHack.Client.Response import Game.LambdaHack.Client.State import Game.LambdaHack.Client.UI import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.Vector -- | Client monad in which one can receive responses from the server. class MonadClient m => MonadClientReadResponse m where receiveResponse :: m Response initAI :: MonadClient m => m () initAI = do side <- getsClient sside debugPossiblyPrint $ "AI client" <+> tshow side <+> "initializing." initUI :: MonadClientUI m => KeyKind -> UIOptions -> m () initUI copsClient sUIOptions = do side <- getsClient sside soptions <- getsClient soptions debugPossiblyPrint $ "UI client" <+> tshow side <+> "initializing." -- Start the frontend. schanF <- chanFrontend soptions let !sbinding = stdBinding copsClient sUIOptions -- evaluate to check for errors modifySession $ \sess -> sess { schanF , sbinding , sxhair = TVector $ Vector 1 1 } -- a step south-east, less alarming -- | The main game loop for an AI or UI client. It receives responses from -- the server, changes internal client state accordingly, analyzes -- ensuing human or AI commands and sends resulting requests to the server. -- Depending on whether it's an AI or UI client, it sends AI or human player -- requests. -- -- The loop is started in client state that is empty except for -- the @sside@ and @seps@ fields, see 'emptyStateClient'. loopCli :: ( MonadClientSetup m , MonadClientUI m , MonadClientAtomic m , MonadClientReadResponse m , MonadClientWriteRequest m ) => KeyKind -> UIOptions -> ClientOptions -> m () loopCli copsClient sUIOptions soptions = do modifyClient $ \cli -> cli {soptions} hasUI <- clientHasUI if not hasUI then initAI else initUI copsClient sUIOptions -- Warning: state and client state are invalid here, e.g., sdungeon -- and sper are empty. restoredG <- tryRestore restored <- case restoredG of Just (cli, msess) | not $ snewGameCli soptions -> do -- Restore game. schanF <- getsSession schanF sbinding <- getsSession sbinding maybe (return ()) (\sess -> modifySession $ \_ -> sess {schanF, sbinding, sUIOptions}) msess putClient cli {soptions} return True Just (_, msessR) -> do -- Preserve previous history, if any (--newGame). maybe (return ()) (\sessR -> modifySession $ \sess -> sess {shistory = shistory sessR}) msessR return False _ -> return False side <- getsClient sside cmd1 <- receiveResponse case (restored, cmd1) of (True, RespUpdAtomic _ UpdResume{}) -> return () (True, RespUpdAtomic _ UpdRestart{}) -> when hasUI $ msgAdd "Ignoring an old savefile and starting a new game." (False, RespUpdAtomic _ UpdResume{}) -> error $ "Savefile of client " ++ show side ++ " not usable." `showFailure` () (False, RespUpdAtomic _ UpdRestart{}) -> return () (True, RespUpdAtomicNoState UpdResume{}) -> undefined (True, RespUpdAtomicNoState UpdRestart{}) -> when hasUI $ msgAdd "Ignoring an old savefile and starting a new game." (False, RespUpdAtomicNoState UpdResume{}) -> error $ "Savefile of client " ++ show side ++ " not usable." `showFailure` () (False, RespUpdAtomicNoState UpdRestart{}) -> return () _ -> error $ "unexpected command" `showFailure` (side, restored, cmd1) handleResponse cmd1 -- State and client state now valid. debugPossiblyPrint $ "UI client" <+> tshow side <+> "started." loop debugPossiblyPrint $ "UI client" <+> tshow side <+> "stopped." where loop = do cmd <- receiveResponse handleResponse cmd quit <- getsClient squit unless quit loop LambdaHack-0.8.3.0/Game/LambdaHack/Client/AI.hs0000644000000000000000000000567613315545734016730 0ustar0000000000000000-- | Ways for the client to use AI to produce server requests, based on -- the client's view of the game state. module Game.LambdaHack.Client.AI ( queryAI #ifdef EXPOSE_INTERNAL -- * Internal operations , pickActorAndAction #endif ) where import Prelude () import Game.LambdaHack.Common.Prelude import qualified Data.EnumMap.Strict as EM import Game.LambdaHack.Client.AI.HandleAbilityM import Game.LambdaHack.Client.AI.PickActorM import Game.LambdaHack.Client.MonadClient import Game.LambdaHack.Client.Request import Game.LambdaHack.Client.State import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.MonadStateRead import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.State -- | Handle the move of an actor under AI control (regardless if the whole -- faction is under human or computer control). queryAI :: MonadClient m => ActorId -> m RequestAI queryAI aid = do -- @sleader@ may be different from @gleader@ due to @stopPlayBack@, -- but only leaders may change faction leader, so we fix that: side <- getsClient sside mleader <- getsState $ gleader . (EM.! side) . sfactionD mleaderCli <- getsClient sleader unless (Just aid == mleader || mleader == mleaderCli) $ -- @aid@ is not the leader, so he can't change leader modifyClient $ \cli -> cli {_sleader = mleader} (aidToMove, treq, oldFlee) <- pickActorAndAction Nothing aid (aidToMove2, treq2) <- case treq of ReqWait | mleader == Just aid -> do -- Leader waits; a waste; try once to pick a yet different leader. -- Undo state changes in @pickAction@: modifyClient $ \cli -> cli { _sleader = mleader , sfleeD = case oldFlee of Just p -> EM.insert aidToMove p $ sfleeD cli Nothing -> EM.delete aidToMove $ sfleeD cli } (a, t, _) <- pickActorAndAction (Just (aidToMove, treq)) aid return (a, t) _ -> return (aidToMove, treq) return ( ReqAITimed treq2 , if aidToMove2 /= aid then Just aidToMove2 else Nothing ) -- | Pick an actor to move and an action for him to perform, given an optional -- previous candidate actor and action and the server-proposed actor. pickActorAndAction :: MonadClient m => Maybe (ActorId, RequestTimed) -> ActorId -> m (ActorId, RequestTimed, Maybe Point) -- This inline speeds up execution by 15% and decreases allocation by 15%, -- despite probably bloating executable: {-# INLINE pickActorAndAction #-} pickActorAndAction maid aid = do mleader <- getsClient sleader aidToMove <- if mleader == Just aid then pickActorToMove (fst <$> maid) else do setTargetFromTactics aid return aid oldFlee <- getsClient $ EM.lookup aidToMove . sfleeD treq <- case maid of Just (aidOld, treqOld) | aidToMove == aidOld -> return treqOld -- no better leader found _ -> pickAction aidToMove (isJust maid) return (aidToMove, treq, oldFlee) LambdaHack-0.8.3.0/Game/LambdaHack/Client/Request.hs0000644000000000000000000000323013315545734020047 0ustar0000000000000000-- | Abstract syntax of requests. -- -- See -- . module Game.LambdaHack.Client.Request ( RequestAI, ReqAI(..), RequestUI, ReqUI(..), RequestTimed(..) ) where import Prelude () import Game.LambdaHack.Common.Prelude import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.Item import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.Vector import Game.LambdaHack.Content.ModeKind -- | Requests sent by AI clients to the server. If faction leader is to be -- changed, it's included as the second component. type RequestAI = (ReqAI, Maybe ActorId) -- | Possible forms of requests sent by AI clients. data ReqAI = ReqAINop | ReqAITimed RequestTimed deriving Show -- | Requests sent by UI clients to the server. If faction leader is to be -- changed, it's included as the second component. type RequestUI = (ReqUI, Maybe ActorId) -- | Possible forms of requests sent by UI clients. data ReqUI = ReqUINop | ReqUITimed RequestTimed | ReqUIGameRestart (GroupName ModeKind) Challenge | ReqUIGameDropAndExit | ReqUIGameSaveAndExit | ReqUIGameSave | ReqUITactic Tactic | ReqUIAutomate deriving Show -- | Requests that take game time, indexed by actor ability -- that is needed for performing the corresponding actions. data RequestTimed = ReqMove Vector | ReqMelee ActorId ItemId CStore | ReqDisplace ActorId | ReqAlter Point | ReqWait | ReqWait10 | ReqMoveItems [(ItemId, Int, CStore, CStore)] | ReqProject Point Int ItemId CStore | ReqApply ItemId CStore deriving Show LambdaHack-0.8.3.0/Game/LambdaHack/Client/CommonM.hs0000644000000000000000000001710713315545734017774 0ustar0000000000000000-- | Common client monad operations. module Game.LambdaHack.Client.CommonM ( getPerFid, aidTgtToPos, makeLine , maxActorSkillsClient, currentSkillsClient, pickWeaponClient , updateSalter, createSalter ) where import Prelude () import Game.LambdaHack.Common.Prelude import qualified Data.EnumMap.Strict as EM import Game.LambdaHack.Client.MonadClient import Game.LambdaHack.Client.Request 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 qualified Game.LambdaHack.Common.ItemAspect as IA import Game.LambdaHack.Common.Kind import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.MonadStateRead import Game.LambdaHack.Common.Perception import Game.LambdaHack.Common.Point import qualified Game.LambdaHack.Common.PointArray as PointArray import Game.LambdaHack.Common.Random 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.TileKind (TileKind, isUknownSpace) -- | Get the current perception of a client. getPerFid :: MonadClient m => LevelId -> m Perception getPerFid lid = do fper <- getsClient sfper let assFail = error $ "no perception at given level" `showFailure` (lid, fper) return $! EM.findWithDefault assFail lid fper -- | Calculate the position of an actor's target. aidTgtToPos :: ActorId -> LevelId -> Target -> State -> Maybe Point aidTgtToPos aid lidV tgt s = case tgt of TEnemy a _ -> let body = getActorBody a s in if blid body == lidV then Just (bpos body) else Nothing TPoint _ lid p -> if lid == lidV then Just p else Nothing TVector v -> let b = getActorBody aid s Level{lxsize, lysize} = sdungeon s EM.! lidV shifted = shiftBounded lxsize lysize (bpos b) v in if shifted == bpos b && v /= Vector 0 0 then Nothing else Just shifted -- | Counts the number of steps until the projectile would hit -- 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 :: MonadStateRead m => Bool -> Actor -> Point -> Int -> m (Maybe Int) makeLine onlyFirst body fpos epsOld = do COps{coTileSpeedup} <- getsState scops lvl@Level{lxsize, lysize} <- getLevel (blid body) posA <- getsState $ \s p -> posToAssocs p (blid body) s let dist = chessDist (bpos body) fpos calcScore eps = case bla lxsize lysize eps (bpos body) fpos of Just bl -> let blDist = take (dist - 1) bl -- goal not checked; actor well aware noActor p = all (bproj . snd) (posA p) || p == fpos accessibleUnknown tpos = let tt = lvl `at` tpos in Tile.isWalkable coTileSpeedup tt || isUknownSpace tt accessU = all noActor blDist && all accessibleUnknown blDist accessFirst | not onlyFirst = False | otherwise = all noActor (take 1 blDist) && all accessibleUnknown (take 1 blDist) nUnknown = length $ filter (isUknownSpace . (lvl `at`)) blDist in if | accessU -> - nUnknown | accessFirst -> -10000 | otherwise -> minBound Nothing -> error $ "" `showFailure` (body, fpos, epsOld) tryLines 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 -> Nothing -- ProjectAimOnself | calcScore epsOld > minBound -> Just epsOld -- keep old | otherwise -> tryLines (epsOld + 1) (Nothing, minBound) -- generate best -- @MonadStateRead@ would be enough, but the logic is sound only on client. maxActorSkillsClient :: MonadClient m => ActorId -> m Ability.Skills maxActorSkillsClient aid = do ar <- getsState $ getActorAspect aid return $ IA.aSkills ar -- keep it lazy currentSkillsClient :: MonadClient m => ActorId -> m Ability.Skills currentSkillsClient aid = do body <- getsState $ getActorBody aid side <- getsClient sside -- Newest Leader in sleader, not yet in sfactionD. mleader <- if side == bfid body then getsClient sleader else do fact <- getsState $ (EM.! bfid body) . sfactionD return $! gleader fact getsState $ actorSkills mleader aid -- keep it lazy -- Client has to choose the weapon based on its partial knowledge, -- because if server chose it, it would leak item discovery information. -- -- Note that currently the stats of the target actor are not considered, -- because all weapons share the sum of all source actor stats and only differ -- in damage (equally important for all targets) and effects (really hard -- to tell which is better for which target or even which is better -- for the same target, so it's random). If only individual weapon's +toHit -- was applied to the target, situation would be much more complex, -- which is precisely why we keep it as is and let the player make choices -- by equipping and unequipping weapons instead. Content should ensure -- that the rule of thumb (which AI uses) that more weapons is better -- should give good results almost always, at least at the start of the game, -- to limit micromanagement and to spare newbies. -- -- Note that situation is completely different with choosing projectiles -- against a particular foe, even before (potential) splash damage -- that hits multiple tagets comes into the equation. AI has to be very -- primitive and random here as well. pickWeaponClient :: MonadClient m => ActorId -> ActorId -> m (Maybe RequestTimed) pickWeaponClient source target = do eqpAssocs <- getsState $ kitAssocs source [CEqp] bodyAssocs <- getsState $ kitAssocs source [COrgan] actorSk <- currentSkillsClient source let kitAssRaw = eqpAssocs ++ bodyAssocs kitAss = filter (IK.isMelee . itemKind . fst . snd) kitAssRaw discoBenefit <- getsClient sdiscoBenefit strongest <- pickWeaponM (Just discoBenefit) kitAss actorSk source case strongest of [] -> 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 updateSalter :: MonadClient m => LevelId -> [(Point, ContentId TileKind)] -> m () updateSalter lid pts = do COps{coTileSpeedup} <- getsState scops let pas = map (second $ toEnum . Tile.alterMinWalk coTileSpeedup) pts f = (PointArray.// pas) modifyClient $ \cli -> cli {salter = EM.adjust f lid $ salter cli} createSalter :: State -> AlterLid createSalter s = let COps{coTileSpeedup} = scops s f Level{ltile} = PointArray.mapA (toEnum . Tile.alterMinWalk coTileSpeedup) ltile in EM.map f $ sdungeon s LambdaHack-0.8.3.0/Game/LambdaHack/Client/HandleResponseM.hs0000644000000000000000000000462713315545734021461 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} -- | Semantics of responses sent by the server to clients. module Game.LambdaHack.Client.HandleResponseM ( MonadClientWriteRequest(..) , MonadClientAtomic(..) , handleResponse ) where import Prelude () import Game.LambdaHack.Common.Prelude import Game.LambdaHack.Atomic (UpdAtomic) import Game.LambdaHack.Client.AI import Game.LambdaHack.Client.HandleAtomicM import Game.LambdaHack.Client.MonadClient import Game.LambdaHack.Client.Request import Game.LambdaHack.Client.Response import Game.LambdaHack.Client.UI import Game.LambdaHack.Common.MonadStateRead import Game.LambdaHack.Common.State -- | Client monad in which one can send requests to the client. class MonadClient m => MonadClientWriteRequest m where sendRequestAI :: RequestAI -> m () sendRequestUI :: RequestUI -> m () clientHasUI :: m Bool -- | Monad for executing atomic game state transformations on a client. class MonadClient m => MonadClientAtomic m where -- | Execute an atomic update that changes the client's 'State'. execUpdAtomic :: UpdAtomic -> m () -- | Put state that is intended to be the result of performing -- an atomic update by the server on its copy of the client's 'State'. execPutState :: State -> m () -- | Handle server responses. -- -- Note that for clients communicating with the server over the net, -- @RespUpdAtomicNoState@ should be used, because executing a single command -- is cheaper than sending the whole state over the net. -- However, for the standalone exe mode, with clients in the same process -- as the server, a pointer to the state set with @execPutState@ is cheaper. handleResponse :: ( MonadClientSetup m , MonadClientUI m , MonadClientAtomic m , MonadClientWriteRequest m ) => Response -> m () handleResponse cmd = case cmd of RespUpdAtomic newState cmdA -> do oldState <- getState execPutState newState cmdAtomicSemCli oldState cmdA hasUI <- clientHasUI when hasUI $ displayRespUpdAtomicUI False cmdA RespUpdAtomicNoState cmdA -> do oldState <- getState execUpdAtomic cmdA cmdAtomicSemCli oldState cmdA hasUI <- clientHasUI when hasUI $ displayRespUpdAtomicUI False cmdA RespQueryAI aid -> do cmdC <- queryAI aid sendRequestAI cmdC RespSfxAtomic sfx -> displayRespSfxAtomicUI False sfx RespQueryUI -> do cmdH <- queryUI sendRequestUI cmdH LambdaHack-0.8.3.0/Game/LambdaHack/Client/Bfs.hs0000644000000000000000000002645613315545734017150 0ustar0000000000000000{-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving, TypeFamilies #-} -- | Breadth first search algorithm. module Game.LambdaHack.Client.Bfs ( BfsDistance, MoveLegal(..), minKnownBfs, apartBfs, maxBfsDistance, fillBfs , AndPath(..), findPathBfs , accessBfs #ifdef EXPOSE_INTERNAL -- * Internal operations , abortedKnownBfs, abortedUnknownBfs #endif ) where import Prelude () import Game.LambdaHack.Common.Prelude import Control.Monad.ST.Strict import Data.Binary import Data.Bits (Bits, complement, (.&.), (.|.)) import qualified Data.Vector.Unboxed as U import qualified Data.Vector.Unboxed.Mutable as VM import GHC.Generics (Generic) import Game.LambdaHack.Common.Point import qualified Game.LambdaHack.Common.PointArray as PointArray -- | Weighted distance between points along shortest paths. newtype BfsDistance = BfsDistance {bfsDistance :: Word8} deriving (Show, Eq, Ord, Enum, Bits) instance PointArray.UnboxRepClass BfsDistance where type UnboxRep BfsDistance = Word8 toUnboxRepUnsafe = bfsDistance fromUnboxRep = BfsDistance -- | State of legality of moves between adjacent points. data MoveLegal = MoveBlocked | MoveToOpen | MoveToClosed | MoveToUnknown deriving Eq -- | The minimal distance value assigned to paths that don't enter -- any unknown tiles. minKnownBfs :: BfsDistance minKnownBfs = BfsDistance $ toEnum $ (1 + fromEnum (maxBound :: Word8)) `div` 2 -- | The distance value that denotes no legal path between points, -- either due to blocked tiles or pathfinding aborted at earlier tiles, -- e.g., due to unknown tiles. apartBfs :: BfsDistance apartBfs = pred minKnownBfs -- | Maximum value of the type. maxBfsDistance :: BfsDistance maxBfsDistance = BfsDistance (maxBound :: Word8) -- | The distance value that denotes that path search was aborted -- at this tile due to too large actual distance -- and that the tile was known and not blocked. -- It is also a true distance value for this tile -- (shifted by minKnownBfs, as all distances of known tiles). abortedKnownBfs :: BfsDistance abortedKnownBfs = pred maxBfsDistance -- | The distance value that denotes that path search was aborted -- at this tile due to too large actual distance -- and that the tile was unknown. -- It is also a true distance value for this tile. abortedUnknownBfs :: BfsDistance abortedUnknownBfs = pred apartBfs type PointI = Int type VectorI = Int -- | 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. -- -- When computing move cost, we assume doors openable at no cost, -- because other actors use them, too, so the cost is shared and the extra -- visiblity is valuable, too. We treat unknown tiles specially. -- Whether suspect tiles are considered openable depends on @smarkSuspect@. fillBfs :: PointArray.Array Word8 -> Word8 -> Point -- ^ starting position -> PointArray.Array BfsDistance -- ^ initial array, with @apartBfs@ -> () {-# INLINE fillBfs #-} fillBfs lalter alterSkill source arr@PointArray.Array{..} = let vToI (x, y) = PointArray.pindex axsize (Point x y) movesI :: [VectorI] movesI = map vToI [(-1, -1), (0, -1), (1, -1), (1, 0), (1, 1), (0, 1), (-1, 1), (-1, 0)] unsafeWriteI :: Int -> BfsDistance -> () {-# INLINE unsafeWriteI #-} unsafeWriteI p c = runST $ do vThawed <- U.unsafeThaw avector VM.unsafeWrite vThawed p (bfsDistance c) void $ U.unsafeFreeze vThawed bfs :: BfsDistance -> [PointI] -> () -- modifies the vector bfs !distance !predK = let processKnown :: PointI -> [PointI] -> [PointI] processKnown !pos !succK2 = -- Terrible hack trigger warning! -- Unsafe ops inside @fKnown@ seem to be OK, for no particularly -- clear reason. The array value given to each p depends on -- array value only at p (it's not overwritten if already there). -- So the only problem with the unsafe ops writing at p is -- if one with higher depth (dist) is evaluated earlier -- than another with lower depth. The particular pattern of -- laziness and order of list elements below somehow -- esures the lowest possible depth is always written first. -- The code also doesn't keep a wholly evaluated list of all p -- at a given depth, but generates them on demand, unlike a fully -- strict version inside the ST monad. So it uses little memory -- and is fast. let fKnown :: [PointI] -> VectorI -> [PointI] fKnown !l !move = let !p = pos + move visitedMove = BfsDistance (arr `PointArray.accessI` p) /= apartBfs in if visitedMove then l else let alter :: Word8 !alter = lalter `PointArray.accessI` p in if | alterSkill < alter -> l | alter == 1 -> let distCompl = distance .&. complement minKnownBfs in unsafeWriteI p distCompl `seq` l | otherwise -> unsafeWriteI p distance `seq` p : l in foldl' fKnown succK2 movesI succK4 = foldr processKnown [] predK in if null succK4 || distance == abortedKnownBfs then () -- no more dungeon positions to check, or we delved too deep else bfs (succ distance) succK4 in bfs (succ minKnownBfs) [PointArray.pindex axsize source] data AndPath = AndPath { pathList :: [Point] , pathGoal :: Point -- needn't be @last pathList@ , pathLen :: Int -- needn't be @length pathList@ } | NoPath deriving (Show, Generic) instance Binary AndPath -- | Find a path, without the source position, with the smallest length. -- The @eps@ coefficient determines which direction (of the closest -- directions available) that path should prefer, where 0 means north-west -- and 1 means north. findPathBfs :: PointArray.Array Word8 -> (Point -> Bool) -> Point -> Point -> Int -> PointArray.Array BfsDistance -> AndPath {-# INLINE findPathBfs #-} findPathBfs lalter fovLit pathSource pathGoal sepsRaw arr@PointArray.Array{..} = let !pathGoalI = PointArray.pindex axsize pathGoal !pathSourceI = PointArray.pindex axsize pathSource eps = sepsRaw `mod` 4 (mc1, mc2) = splitAt eps [(0, -1), (1, 0), (0, 1), (-1, 0)] (md1, md2) = splitAt eps [(-1, -1), (1, -1), (1, 1), (-1, 1)] -- Prefer cardinal directions when closer to the target, so that -- the enemy can't easily disengage (open/unknown below overrides that). prefMoves = mc1 ++ reverse mc2 ++ md2 ++ reverse md1 -- fuzz vToI (x, y) = PointArray.pindex axsize (Point x y) movesI :: [VectorI] movesI = map vToI prefMoves track :: PointI -> BfsDistance -> [Point] -> [Point] track !pos !oldDist !suffix | oldDist == minKnownBfs = assert (pos == pathSourceI) suffix track pos oldDist suffix | oldDist == succ minKnownBfs = let !posP = PointArray.punindex axsize pos in posP : suffix -- avoid calculating minP and dist for the last call track pos oldDist suffix = let !dist = pred oldDist minChild !minP _ _ [] = minP minChild minP maxDark minAlter (mv : mvs) = let !p = pos + mv backtrackingMove = BfsDistance (arr `PointArray.accessI` p) /= dist in if backtrackingMove then minChild minP maxDark minAlter mvs else let alter = lalter `PointArray.accessI` p dark = not $ fovLit $ PointArray.punindex axsize p -- Prefer paths through more easily opened tiles -- and, secondly, in the ambient dark (even if light -- carried, because it can be taken off at any moment). in if | alter == 0 && dark -> p -- speedup | alter < minAlter -> minChild p dark alter mvs | dark > maxDark && alter == minAlter -> minChild p dark alter mvs | otherwise -> minChild minP maxDark minAlter mvs -- @maxBound@ means not alterable, so some child will be lower !newPos = minChild pos{-dummy-} False maxBound movesI #ifdef WITH_EXPENSIVE_ASSERTIONS !_A = assert (newPos /= pos) () #endif !posP = PointArray.punindex axsize pos in track newPos dist (posP : suffix) !goalDist = BfsDistance $ arr `PointArray.accessI` pathGoalI pathLen = fromEnum $ goalDist .&. complement minKnownBfs pathList = track pathGoalI (goalDist .|. minKnownBfs) [] andPath = AndPath{..} in assert (BfsDistance (arr `PointArray.accessI` pathSourceI) == minKnownBfs) $ if goalDist /= apartBfs && pathLen < 2 * chessDist pathSource pathGoal then andPath else let f :: (Point, Int, Int, Int) -> Point -> BfsDistance -> (Point, Int, Int, Int) f acc@(pAcc, dAcc, chessAcc, sumAcc) p d = if d <= abortedUnknownBfs -- works in visible secrets mode only || d /= apartBfs && adjacent p pathGoal -- works for stairs then let dist = fromEnum $ d .&. complement minKnownBfs chessNew = chessDist p pathGoal sumNew = dist + 2 * chessNew resNew = (p, dist, chessNew, sumNew) in case compare sumNew sumAcc of LT -> resNew EQ -> case compare chessNew chessAcc of LT -> resNew EQ -> case compare dist dAcc of LT -> resNew EQ | euclidDistSq p pathGoal < euclidDistSq pAcc pathGoal -> resNew _ -> acc _ -> acc _ -> acc else acc initAcc = (originPoint, maxBound, maxBound, maxBound) (pRes, dRes, _, sumRes) = PointArray.ifoldlA' f initAcc arr in if sumRes == maxBound || goalDist /= apartBfs && pathLen < sumRes then if goalDist /= apartBfs then andPath else NoPath else let pathList2 = track (PointArray.pindex axsize pRes) (toEnum dRes .|. minKnownBfs) [] in AndPath{pathList = pathList2, pathLen = sumRes, ..} -- | Access a BFS array and interpret the looked up distance value. accessBfs :: PointArray.Array BfsDistance -> Point -> Maybe Int accessBfs bfs p = let dist = bfs PointArray.! p in if dist == apartBfs then Nothing else Just $ fromEnum $ dist .&. complement minKnownBfs LambdaHack-0.8.3.0/Game/LambdaHack/Client/UI.hs0000644000000000000000000001705413315545734016745 0ustar0000000000000000-- | 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 ( -- * Querying the human player queryUI -- * UI monad and session type , MonadClientUI(..), SessionUI(..) -- * Updating UI state wrt game state changes , displayRespUpdAtomicUI, displayRespSfxAtomicUI -- * Startup and initialization , KeyKind , UIOptions, applyUIOptions, uCmdline, mkUIOptions -- * Operations exposed for "Game.LambdaHack.Client.LoopM" , ChanFrontend, chanFrontend, msgAdd, tryRestore, stdBinding #ifdef EXPOSE_INTERNAL -- * Internal operations , humanCommand #endif ) where import Prelude () import Game.LambdaHack.Common.Prelude import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES import qualified Data.Map.Strict as M import qualified Data.Text as T import Game.LambdaHack.Client.ClientOptions import Game.LambdaHack.Client.MonadClient import Game.LambdaHack.Client.Request import Game.LambdaHack.Client.State import Game.LambdaHack.Client.UI.Content.KeyKind import Game.LambdaHack.Client.UI.DisplayAtomicM import Game.LambdaHack.Client.UI.FrameM import Game.LambdaHack.Client.UI.Frontend import Game.LambdaHack.Client.UI.HandleHelperM import Game.LambdaHack.Client.UI.HandleHumanM import qualified Game.LambdaHack.Client.UI.Key as K import Game.LambdaHack.Client.UI.KeyBindings import Game.LambdaHack.Client.UI.MonadClientUI import Game.LambdaHack.Client.UI.Msg import Game.LambdaHack.Client.UI.MsgM import Game.LambdaHack.Client.UI.Overlay import Game.LambdaHack.Client.UI.SessionUI import Game.LambdaHack.Client.UI.Slideshow import Game.LambdaHack.Client.UI.SlideshowM import Game.LambdaHack.Client.UI.UIOptions import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.MonadStateRead import Game.LambdaHack.Common.State import Game.LambdaHack.Content.ModeKind -- | Handle the move of a human player. queryUI :: MonadClientUI m => m RequestUI queryUI = do side <- getsClient sside fact <- getsState $ (EM.! side) . sfactionD if isAIFact fact then do recordHistory keyPressed <- anyKeyPressed if keyPressed && fleaderMode (gplayer fact) /= LeaderNull then do discardPressedKey addPressedEsc -- Regaining control of faction cancels --stopAfter*. modifyClient $ \cli -> cli {soptions = (soptions cli) { sstopAfterSeconds = Nothing , sstopAfterFrames = Nothing }} return (ReqUIAutomate, Nothing) -- stop AI else do -- As long as UI faction is under AI control, check, once per move, -- for benchmark game stop. stopAfterFrames <- getsClient $ sstopAfterFrames . soptions bench <- getsClient $ sbenchmark . soptions let exitCmd = if bench then ReqUIGameDropAndExit else ReqUIGameSaveAndExit case stopAfterFrames of Nothing -> do stopAfterSeconds <- getsClient $ sstopAfterSeconds . soptions case stopAfterSeconds of Nothing -> return (ReqUINop, Nothing) Just stopS -> do exit <- elapsedSessionTimeGT stopS if exit then do tellAllClipPS return (exitCmd, Nothing) -- ask server to exit else return (ReqUINop, Nothing) Just stopF -> do allNframes <- getsSession sallNframes gnframes <- getsSession snframes if allNframes + gnframes >= stopF then do tellAllClipPS return (exitCmd, Nothing) -- ask server to exit else return (ReqUINop, Nothing) else do let mleader = gleader fact !_A = assert (isJust mleader) () req <- humanCommand leader2 <- getLeaderUI -- Don't send the leader switch to the server with these commands, -- to avoid leader death at resume if his HP <= 0. That would violate -- the principle that save and reload doesn't change game state. let saveCmd cmd = case cmd of ReqUIGameDropAndExit -> True ReqUIGameSaveAndExit -> True ReqUIGameSave -> True _ -> False return (req, if mleader /= Just leader2 && not (saveCmd req) then Just leader2 else Nothing) -- | Let the human player issue commands until any command takes time. humanCommand :: forall m. MonadClientUI m => m ReqUI humanCommand = do modifySession $ \sess -> sess { slastLost = ES.empty , shintMode = HintAbsent } let loop :: m ReqUI loop = do report <- getsSession $ newReport . shistory hintMode <- getsSession shintMode -- Hints are not considered non-empty reports. modifySession $ \sess -> sess {sreportNull = nullReport report || hintMode == HintShown} case hintMode of HintAbsent -> return () HintShown -> modifySession $ \sess -> sess {shintMode = HintWiped} HintWiped -> modifySession $ \sess -> sess {shintMode = HintAbsent} slidesRaw <- reportToSlideshowKeep [] over <- case unsnoc slidesRaw of Nothing -> return [] Just (allButLast, (ov, _)) -> if allButLast == emptySlideshow then -- Display the only generated slide while waiting for next key. -- Strip the "--end-" prompt from it. return $! init ov else do -- Show, one by one, all slides, awaiting confirmation for each. void $ getConfirms ColorFull [K.spaceKM, K.escKM] slidesRaw -- Display base frame at the end. return [] LastRecord seqCurrent seqPrevious k <- getsSession slastRecord let slastRecord | k == 0 = LastRecord [] seqCurrent 0 | otherwise = LastRecord [] (seqCurrent ++ seqPrevious) (k - 1) modifySession $ \sess -> sess {slastRecord} lastPlay <- getsSession slastPlay leader <- getLeaderUI b <- getsState $ getActorBody leader when (bhp b <= 0) $ displayMore ColorBW "If you move, the exertion will kill you. Consider asking for first aid instead." km <- promptGetKey ColorFull over False [] -- Messages shown, so update history and reset current report. when (null lastPlay) recordHistory abortOrCmd <- do -- Look up the key. Binding{bcmdMap} <- getsSession sbinding case km `M.lookup` bcmdMap of Just (_, _, cmd) -> do modifySession $ \sess -> sess {swaitTimes = if swaitTimes sess > 0 then - swaitTimes sess else 0} cmdHumanSem cmd _ -> let msgKey = "unknown command <" <> K.showKM km <> ">" in weaveJust <$> failWith (T.pack 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 report could have been generated. return cmdS Left Nothing -> loop Left (Just err) -> do stopPlayBack promptAdd1 $ showFailError err loop loop LambdaHack-0.8.3.0/Game/LambdaHack/Client/MonadClient.hs0000644000000000000000000000360713315545734020624 0ustar0000000000000000-- | Basic client monad and related operations. module Game.LambdaHack.Client.MonadClient ( -- * Basic client monads MonadClient( getsClient , modifyClient , liftIO -- exposed only to be implemented, not used ) -- * Assorted primitives , getClient, putClient , debugPossiblyPrint, rndToAction, rndToActionForget ) where import Prelude () import Game.LambdaHack.Common.Prelude import qualified Control.Monad.Trans.State.Strict as St import qualified Data.Text.IO as T import System.IO (hFlush, stdout) import Game.LambdaHack.Client.ClientOptions import Game.LambdaHack.Client.State import Game.LambdaHack.Common.MonadStateRead import Game.LambdaHack.Common.Random -- | Monad for writing to client state. class MonadStateRead m => MonadClient m where getsClient :: (StateClient -> a) -> m a modifyClient :: (StateClient -> StateClient) -> m () -- We do not provide a MonadIO instance, so that outside -- nobody can subvert the action monads by invoking arbitrary IO. liftIO :: IO a -> m a getClient :: MonadClient m => m StateClient getClient = getsClient id putClient :: MonadClient m => StateClient -> m () putClient s = modifyClient (const s) debugPossiblyPrint :: MonadClient m => Text -> m () debugPossiblyPrint t = do sdbgMsgCli <- getsClient $ sdbgMsgCli . soptions when sdbgMsgCli $ liftIO $ do T.hPutStrLn stdout t hFlush stdout -- | Invoke pseudo-random computation with the generator kept in the state. rndToAction :: MonadClient m => Rnd a -> m a rndToAction r = do gen1 <- getsClient srandom let (a, gen2) = St.runState r gen1 modifyClient $ \cli -> cli {srandom = gen2} return a -- | Invoke pseudo-random computation, don't change generator kept in state. rndToActionForget :: MonadClient m => Rnd a -> m a rndToActionForget r = do gen <- getsClient srandom return $! St.evalState r gen LambdaHack-0.8.3.0/Game/LambdaHack/Client/State.hs0000644000000000000000000001512413315545734017504 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} -- | Client-specific game state components. module Game.LambdaHack.Client.State ( StateClient(..), AlterLid, BfsAndPath(..), TgtAndPath(..) , emptyStateClient, cycleMarkSuspect , updateTarget, getTarget, updateLeader, sside, sleader ) where import Prelude () import Game.LambdaHack.Common.Prelude import Data.Binary import qualified Data.EnumMap.Lazy as LEM import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES import qualified Data.Map.Strict as M import GHC.Generics (Generic) import qualified System.Random as R import Game.LambdaHack.Atomic import Game.LambdaHack.Client.Bfs import Game.LambdaHack.Client.ClientOptions import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.Item import Game.LambdaHack.Common.Kind import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Perception import Game.LambdaHack.Common.Point import qualified Game.LambdaHack.Common.PointArray as PointArray import Game.LambdaHack.Common.State import Game.LambdaHack.Content.ModeKind (ModeKind) -- | Client state, belonging to a single faction. data StateClient = StateClient { seps :: Int -- ^ a parameter of the aiming digital line , stargetD :: EM.EnumMap ActorId TgtAndPath -- ^ targets of our actors in the dungeon , sfleeD :: EM.EnumMap ActorId Point -- ^ the position when fleeing requested , sexplored :: ES.EnumSet LevelId -- ^ the set of fully explored levels , sbfsD :: EM.EnumMap ActorId BfsAndPath -- ^ pathfinding data for our actors , sundo :: [CmdAtomic] -- ^ atomic commands performed to date , sdiscoBenefit :: DiscoveryBenefit -- ^ remembered AI benefits of items; could be recomputed at resume, -- but they are costly to generate and not too large , sfper :: PerLid -- ^ faction perception indexed by level , salter :: AlterLid -- ^ cached alter ability data for positions , srandom :: R.StdGen -- ^ current random generator , _sleader :: Maybe ActorId -- ^ candidate new leader of the faction; -- Faction.gleader is the old leader , _sside :: FactionId -- ^ faction controlled by the client , squit :: Bool -- ^ exit the game loop , scurChal :: Challenge -- ^ current game challenge setup , snxtChal :: Challenge -- ^ next game challenge setup , snxtScenario :: Int -- ^ next game scenario number , smarkSuspect :: Int -- ^ whether to mark suspect features , scondInMelee :: LEM.EnumMap LevelId Bool -- ^ whether we are in melee, per level , svictories :: EM.EnumMap (ContentId ModeKind) (M.Map Challenge Int) -- ^ won games at particular difficulty lvls , soptions :: ClientOptions -- ^ client options } deriving Show type AlterLid = EM.EnumMap LevelId (PointArray.Array Word8) -- | Pathfinding distances to all reachable positions of an actor -- and a shortest paths to some of the positions. data BfsAndPath = BfsInvalid | BfsAndPath { bfsArr :: PointArray.Array BfsDistance , bfsPath :: EM.EnumMap Point AndPath } deriving Show -- | Actor's target and a path to it, if any. data TgtAndPath = TgtAndPath {tapTgt :: Target, tapPath :: AndPath} deriving (Show, Generic) instance Binary TgtAndPath -- | Initial empty game client state. emptyStateClient :: FactionId -> StateClient emptyStateClient _sside = StateClient { seps = fromEnum _sside , stargetD = EM.empty , sfleeD = EM.empty , sexplored = ES.empty , sbfsD = EM.empty , sundo = [] , sdiscoBenefit = EM.empty , sfper = EM.empty , salter = EM.empty , srandom = R.mkStdGen 42 -- will get modified in this and future games , _sleader = Nothing -- no heroes yet alive , _sside , squit = False , scurChal = defaultChallenge , snxtChal = defaultChallenge , snxtScenario = 0 , smarkSuspect = 1 , scondInMelee = LEM.empty , svictories = EM.empty , soptions = defClientOptions } -- | Cycle the 'smarkSuspect' setting. cycleMarkSuspect :: StateClient -> StateClient cycleMarkSuspect s@StateClient{smarkSuspect} = s {smarkSuspect = (smarkSuspect + 1) `mod` 3} -- | Update target parameters within client state. updateTarget :: ActorId -> (Maybe Target -> Maybe Target) -> StateClient -> StateClient updateTarget aid f cli = let f2 tp = case f $ fmap tapTgt tp of Nothing -> Nothing Just tgt -> Just $ TgtAndPath tgt NoPath -- reset path in cli {stargetD = EM.alter f2 aid (stargetD cli)} -- | Get target parameters from client state. getTarget :: ActorId -> StateClient -> Maybe Target getTarget aid cli = fmap tapTgt $ EM.lookup aid $ stargetD cli -- | Update picked leader within state. Verify actor's faction. updateLeader :: ActorId -> State -> StateClient -> StateClient updateLeader leader s cli = let side1 = bfid $ getActorBody leader s side2 = sside cli in assert (side1 == side2 `blame` "enemy actor becomes our leader" `swith` (side1, side2, leader, s)) $ cli {_sleader = Just leader} sside :: StateClient -> FactionId sside = _sside sleader :: StateClient -> Maybe ActorId sleader = _sleader instance Binary StateClient where put StateClient{..} = do put seps put stargetD put sfleeD put sexplored put sundo put sdiscoBenefit put (show srandom) put _sleader put _sside put scurChal put snxtChal put snxtScenario put smarkSuspect put scondInMelee put svictories #ifdef WITH_EXPENSIVE_ASSERTIONS put sfper #endif get = do seps <- get stargetD <- get sfleeD <- get sexplored <- get sundo <- get sdiscoBenefit <- get g <- get _sleader <- get _sside <- get scurChal <- get snxtChal <- get snxtScenario <- get smarkSuspect <- get scondInMelee <- get svictories <- get let sbfsD = EM.empty salter = EM.empty srandom = read g squit = False soptions = defClientOptions #ifndef WITH_EXPENSIVE_ASSERTIONS sfper = EM.empty #else sfper <- get #endif return $! StateClient{..} LambdaHack-0.8.3.0/Game/LambdaHack/Client/HandleAtomicM.hs0000644000000000000000000003772513315545734021104 0ustar0000000000000000-- | Handle atomic commands received by the client. module Game.LambdaHack.Client.HandleAtomicM ( MonadClientSetup(..) , cmdAtomicSemCli #ifdef EXPOSE_INTERNAL -- * Internal operations , wipeBfsIfItemAffectsSkills, tileChangeAffectsBfs, createActor, destroyActor , addItemToDiscoBenefit, perception , discoverKind, coverKind, discoverAspect, coverAspect , killExit #endif ) where import Prelude () import Game.LambdaHack.Common.Prelude import qualified Data.EnumMap.Lazy as LEM import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES import qualified Data.Map.Strict as M import Data.Ord import Game.LambdaHack.Atomic import Game.LambdaHack.Client.Bfs import Game.LambdaHack.Client.BfsM import Game.LambdaHack.Client.CommonM import Game.LambdaHack.Client.MonadClient import Game.LambdaHack.Client.Preferences import Game.LambdaHack.Client.State import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.ItemAspect as IA import Game.LambdaHack.Common.Kind import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.MonadStateRead import Game.LambdaHack.Common.Perception import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile import qualified Game.LambdaHack.Content.CaveKind as CK import Game.LambdaHack.Content.ItemKind (ItemKind) import Game.LambdaHack.Content.ModeKind (ModeKind, fhasGender) import Game.LambdaHack.Content.TileKind (TileKind) -- | Client monad for saving and restarting games. class MonadClient m => MonadClientSetup m where saveClient :: m () restartClient :: m () -- | Effect of atomic actions on client state. It is calculated -- with the global state from after the command is executed -- (except where the supplied @oldState@ is used). cmdAtomicSemCli :: MonadClientSetup m => State -> UpdAtomic -> m () {-# INLINE cmdAtomicSemCli #-} cmdAtomicSemCli oldState cmd = case cmd of UpdCreateActor aid b ais -> createActor aid b ais UpdDestroyActor aid b _ -> destroyActor aid b True UpdCreateItem iid _ _ (CActor aid store) -> do wipeBfsIfItemAffectsSkills [store] aid addItemToDiscoBenefit iid UpdCreateItem iid _ _ _ -> addItemToDiscoBenefit iid UpdDestroyItem _ _ _ (CActor aid store) -> wipeBfsIfItemAffectsSkills [store] aid UpdSpotActor aid b ais -> createActor aid b ais UpdLoseActor aid b _ -> destroyActor aid b False UpdSpotItem _ iid _ _ (CActor aid store) -> do wipeBfsIfItemAffectsSkills [store] aid addItemToDiscoBenefit iid UpdSpotItem _ iid _ _ _ -> addItemToDiscoBenefit iid UpdLoseItem _ _ _ _ (CActor aid store) -> wipeBfsIfItemAffectsSkills [store] aid UpdSpotItemBag (CActor aid store) _bag ais -> do wipeBfsIfItemAffectsSkills [store] aid mapM_ (addItemToDiscoBenefit . fst) ais UpdSpotItemBag _ _ ais -> mapM_ (addItemToDiscoBenefit . fst) ais UpdLoseItemBag (CActor aid store) _bag _ais -> wipeBfsIfItemAffectsSkills [store] aid UpdMoveActor aid _ _ -> do invalidateBfsAid aid b <- getsState $ getActorBody aid recomputeInMelee (blid b) UpdDisplaceActor source target -> do invalidateBfsAid source invalidateBfsAid target b <- getsState $ getActorBody source recomputeInMelee (blid b) UpdMoveItem _ _ aid s1 s2 -> wipeBfsIfItemAffectsSkills [s1, s2] aid UpdLeadFaction fid source target -> do side <- getsClient sside when (side == fid) $ do mleader <- getsClient sleader let !_A = assert (mleader == source -- somebody changed the leader for us || mleader == target -- we changed the leader ourselves `blame` "unexpected leader" `swith` (cmd, mleader)) () modifyClient $ \cli -> cli {_sleader = target} UpdAutoFaction{} -> -- @condBFS@ depends on the setting we change here (e.g., smarkSuspect). invalidateBfsAll UpdTacticFaction{} -> 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 } UpdAlterTile lid p fromTile toTile -> do updateSalter lid [(p, toTile)] cops <- getsState scops let lvl = (EM.! lid) . sdungeon $ oldState t = lvl `at` p let !_A = assert (t == fromTile) () when (tileChangeAffectsBfs cops fromTile toTile) $ invalidateBfsLid lid UpdSearchTile aid p toTile -> do COps{cotile} <- getsState scops b <- getsState $ getActorBody aid let lid = blid b updateSalter lid [(p, toTile)] cops <- getsState scops let lvl = (EM.! lid) . sdungeon $ oldState t = lvl `at` p let !_A = assert (Just t == Tile.hideAs cotile toTile) () -- The following check is needed even if we verity in content -- that searching doesn't change clarity and light of tiles, -- because it modifies skill needed to alter the tile and even -- walkability and changeability. when (tileChangeAffectsBfs cops t toTile) $ invalidateBfsLid lid UpdSpotTile lid ts -> do updateSalter lid ts cops <- getsState scops let lvl = (EM.! lid) . sdungeon $ oldState affects (p, toTile) = let fromTile = lvl `at` p in tileChangeAffectsBfs cops fromTile toTile bs = map affects ts when (or bs) $ invalidateBfsLid lid UpdLoseTile lid ts -> do updateSalter lid ts invalidateBfsLid lid -- from known to unknown tiles UpdDiscover c iid ik aspectRecord -> do item <- getsState $ getItemBody iid discoKind <- getsState sdiscoKind case jkind item of IdentityObvious _ik -> return () IdentityCovered ix _ik | ix `EM.notMember` discoKind -> discoverKind c ix ik IdentityCovered _ix _ik -> return () discoverAspect c iid aspectRecord UpdCover c iid ik aspectRecord -> do coverAspect c iid aspectRecord item <- getsState $ getItemBody iid discoKind <- getsState sdiscoKind case jkind item of IdentityObvious _ik -> return () IdentityCovered ix _ik | ix `EM.member` discoKind -> coverKind c ix ik IdentityCovered _ix _ik -> return () UpdDiscoverKind c ix ik -> discoverKind c ix ik UpdCoverKind c ix ik -> coverKind c ix ik UpdDiscoverAspect c iid aspectRecord -> discoverAspect c iid aspectRecord UpdCoverAspect c iid aspectRecord -> coverAspect c iid aspectRecord UpdPerception lid outPer inPer -> perception lid outPer inPer UpdRestart side sfper s scurChal soptions -> do COps{cocave, comode} <- getsState scops fact <- getsState $ (EM.! side) . sfactionD snxtChal <- getsClient snxtChal svictories <- getsClient svictories let f acc _p i _a = i : acc modes = zip [0..] $ ofoldlGroup' comode "campaign scenario" f [] g :: (Int, ContentId ModeKind) -> Int g (_, mode) = case EM.lookup mode svictories of Nothing -> 0 Just cm -> fromMaybe 0 (M.lookup snxtChal cm) (snxtScenario, _) = minimumBy (comparing g) modes h lvl = CK.cactorCoeff (okind cocave $ lkind lvl) > 150 && not (fhasGender $ gplayer fact) -- Not to burrow through a labyrinth instead of leaving it for -- the human player and to prevent AI losing time there instead -- of congregating at exits. sexplored = EM.keysSet $ EM.filter h $ sdungeon s cli = emptyStateClient side putClient cli { sexplored , sfper -- , sundo = [UpdAtomic cmd] , scurChal , snxtChal , snxtScenario , scondInMelee = LEM.fromAscList $ map (\lid -> (lid, False)) $ EM.keys (sdungeon s) , svictories , soptions } salter <- getsState createSalter modifyClient $ \cli1 -> cli1 {salter} restartClient UpdResume _fid sfperNew -> do #ifdef WITH_EXPENSIVE_ASSERTIONS sfperOld <- getsClient sfper let !_A = assert (sfperNew == sfperOld `blame` (sfperNew, sfperOld)) () #endif modifyClient $ \cli -> cli {sfper=sfperNew} salter <- getsState createSalter modifyClient $ \cli -> cli {salter} UpdKillExit _fid -> killExit UpdWriteSave -> saveClient _ -> return () -- This tweak is only needed in AI client, but it's lazy for each level -- and so fairly cheap. recomputeInMelee :: MonadClient m => LevelId -> m () recomputeInMelee lid = do side <- getsClient sside s <- getState modifyClient $ \cli -> cli {scondInMelee = LEM.insert lid (inMelee side lid s) (scondInMelee cli)} -- For now, only checking the stores. wipeBfsIfItemAffectsSkills :: MonadClient m => [CStore] -> ActorId -> m () wipeBfsIfItemAffectsSkills stores aid = unless (null $ intersect stores [CEqp, COrgan]) $ invalidateBfsAid aid tileChangeAffectsBfs :: COps -> ContentId TileKind -> ContentId TileKind -> Bool tileChangeAffectsBfs COps{coTileSpeedup} fromTile toTile = Tile.alterMinWalk coTileSpeedup fromTile /= Tile.alterMinWalk coTileSpeedup toTile createActor :: MonadClient m => ActorId -> Actor -> [(ItemId, Item)] -> m () createActor aid b ais = do side <- getsClient sside let newPermit = bfid b == side affect3 tap@TgtAndPath{..} = case tapTgt of TPoint (TEnemyPos a _) _ _ | a == aid -> TgtAndPath (TEnemy a newPermit) NoPath _ -> tap modifyClient $ \cli -> cli {stargetD = EM.map affect3 (stargetD cli)} mapM_ (addItemToDiscoBenefit . fst) ais recomputeInMelee (blid b) 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 -> if destroy then -- If *really* nothing more interesting, the actor will -- go to last known location to perhaps find other foes. TPoint TAny (blid b) (bpos b) else -- If enemy only hides (or we stepped behind obstacle) find him. TPoint (TEnemyPos a permit) (blid b) (bpos b) _ -> tgt affect3 TgtAndPath{..} = let newMPath = case tapPath of AndPath{pathGoal} | pathGoal /= bpos b -> NoPath _ -> tapPath -- foe slow enough, so old path good in TgtAndPath (affect tapTgt) newMPath modifyClient $ \cli -> cli {stargetD = EM.map affect3 (stargetD cli)} recomputeInMelee (blid b) addItemToDiscoBenefit :: MonadClient m => ItemId -> m () addItemToDiscoBenefit iid = do cops <- getsState scops discoBenefit <- getsClient sdiscoBenefit case EM.lookup iid discoBenefit of Just{} -> return () -- already there, with real or provisional aspect record, -- but we haven't learned anything new about the item Nothing -> do side <- getsClient sside fact <- getsState $ (EM.! side) . sfactionD itemFull <- getsState $ itemToFull iid let benefit = totalUsefulness cops fact itemFull modifyClient $ \cli -> cli {sdiscoBenefit = EM.insert iid benefit (sdiscoBenefit cli)} perception :: MonadClient m => LevelId -> Perception -> Perception -> m () perception lid outPer inPer = do -- Clients can't compute FOV on their own, because they don't know -- if unknown tiles are clear or not. Server would need to send -- info about properties of unknown tiles, which complicates -- and makes heavier the most bulky data set in the game: tile maps. -- Note we assume, but do not check that @outPer@ is contained -- in current perception and @inPer@ has no common part with it. -- It would make the already very costly operation even more expensive. {- perOld <- getPerFid lid -- Check if new perception is already set in @cmdAtomicFilterCli@ -- or if we are doing undo/redo, which does not involve filtering. -- The data structure is strict, so the cheap check can't be any simpler. let interAlready per = Just $ totalVisible per `ES.intersection` totalVisible perOld unset = maybe False ES.null (interAlready inPer) || maybe False (not . ES.null) (interAlready outPer) when unset $ do -} let adj Nothing = error $ "no perception to alter" `showFailure` lid adj (Just per) = Just $ addPer (diffPer per outPer) inPer f = EM.alter adj lid modifyClient $ \cli -> cli {sfper = f (sfper cli)} discoverKind :: MonadClient m => Container -> ItemKindIx -> ContentId ItemKind -> m () discoverKind _c ix _ik = do cops <- getsState scops -- Wipe out BFS, because the player could potentially learn that his items -- affect his actors' skills relevant to BFS. invalidateBfsAll side <- getsClient sside fact <- getsState $ (EM.! side) . sfactionD itemToF <- getsState $ flip itemToFull let benefit iid = let itemFull = itemToF iid in totalUsefulness cops fact itemFull itemIxMap <- getsState $ (EM.! ix) . sitemIxMap -- Possibly overwrite earlier, provisional benefits. forM_ (ES.elems itemIxMap) $ \iid -> modifyClient $ \cli -> cli {sdiscoBenefit = EM.insert iid (benefit iid) (sdiscoBenefit cli)} coverKind :: Container -> ItemKindIx -> ContentId ItemKind -> m () coverKind _c _ix _ik = undefined discoverAspect :: MonadClient m => Container -> ItemId -> IA.AspectRecord -> m () discoverAspect _c iid _aspectRecord = do cops <- getsState scops -- Wipe out BFS, because the player could potentially learn that his items -- affect his actors' skills relevant to BFS. invalidateBfsAll side <- getsClient sside fact <- getsState $ (EM.! side) . sfactionD itemFull <- getsState $ itemToFull iid let benefit = totalUsefulness cops fact itemFull -- Possibly overwrite earlier, provisional benefits. modifyClient $ \cli -> cli {sdiscoBenefit = EM.insert iid benefit (sdiscoBenefit cli)} coverAspect :: Container -> ItemId -> IA.AspectRecord -> m () coverAspect _c _iid _aspectRecord = undefined killExit :: MonadClient m => m () killExit = do side <- getsClient sside debugPossiblyPrint $ "Client" <+> tshow side <+> "quitting." modifyClient $ \cli -> cli {squit = True} -- Verify that the not saved caches are equal to future reconstructed. -- Otherwise, save/restore would change game state. sactorAspect2 <- getsState sactorAspect salter <- getsClient salter sbfsD <- getsClient sbfsD alter <- getsState createSalter actorAspect <- getsState actorAspectInDungeon let f aid = do (canMove, alterSkill) <- condBFS aid bfsArr <- createBfs canMove alterSkill aid let bfsPath = EM.empty return (aid, BfsAndPath{..}) actorD <- getsState sactorD lbfsD <- mapM f $ EM.keys actorD -- Some freshly generated bfses are not used for comparison, but at least -- we check they don't violate internal assertions themselves. Hence the bang. let bfsD = EM.fromDistinctAscList lbfsD g BfsInvalid !_ = True g _ BfsInvalid = False g bap1 bap2 = bfsArr bap1 == bfsArr bap2 subBfs = EM.isSubmapOfBy g let !_A1 = assert (salter == alter `blame` "wrong accumulated salter on side" `swith` (side, salter, alter)) () !_A2 = assert (sactorAspect2 == actorAspect `blame` "wrong accumulated sactorAspect on side" `swith` (side, sactorAspect2, actorAspect)) () !_A3 = assert (sbfsD `subBfs` bfsD `blame` "wrong accumulated sbfsD on side" `swith` (side, sbfsD, bfsD)) () return () LambdaHack-0.8.3.0/Game/LambdaHack/Client/BfsM.hs0000644000000000000000000004657113315545734017265 0ustar0000000000000000{-# LANGUAGE TupleSections #-} -- | Breadth first search and related algorithms using the client monad. module Game.LambdaHack.Client.BfsM ( invalidateBfsAid, invalidateBfsLid, invalidateBfsAll , createBfs, getCacheBfsAndPath, getCacheBfs , getCachePath, createPath, condBFS , furthestKnown, closestUnknown, closestSmell , FleeViaStairsOrEscape(..) , embedBenefit, closestTriggers, condEnoughGearM, closestItems, closestFoes #ifdef EXPOSE_INTERNAL , unexploredDepth, updatePathFromBfs #endif ) where import Prelude () import Game.LambdaHack.Common.Prelude import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES import Data.Ord import Data.Word import Game.LambdaHack.Client.Bfs import Game.LambdaHack.Client.CommonM 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.Kind import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.MonadStateRead import Game.LambdaHack.Common.Point import qualified Game.LambdaHack.Common.PointArray as PointArray import Game.LambdaHack.Common.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.TileKind (isUknownSpace) invalidateBfsAid :: MonadClient m => ActorId -> m () invalidateBfsAid aid = modifyClient $ \cli -> cli {sbfsD = EM.insert aid BfsInvalid (sbfsD cli)} invalidateBfsLid :: MonadClient m => LevelId -> m () invalidateBfsLid lid = do side <- getsClient sside let f (_, b) = blid b == lid && bfid b == side && not (bproj b) as <- getsState $ filter f . EM.assocs . sactorD mapM_ (invalidateBfsAid . fst) as invalidateBfsAll :: MonadClient m => m () invalidateBfsAll = modifyClient $ \cli -> cli {sbfsD = EM.map (const BfsInvalid) (sbfsD cli)} createBfs :: MonadClient m => Bool -> Word8 -> ActorId -> m (PointArray.Array BfsDistance) createBfs canMove alterSkill aid = do b <- getsState $ getActorBody aid let lid = blid b Level{lxsize, lysize} <- getLevel lid let !aInitial = PointArray.replicateA lxsize lysize apartBfs !source = bpos b !_ = PointArray.unsafeWriteA aInitial source minKnownBfs when canMove $ do salter <- getsClient salter let !lalter = salter EM.! lid !_a = fillBfs lalter alterSkill source aInitial return () return aInitial updatePathFromBfs :: MonadClient m => Bool -> BfsAndPath -> ActorId -> Point -> m (PointArray.Array BfsDistance, AndPath) updatePathFromBfs canMove bfsAndPathOld aid !target = do COps{coTileSpeedup} <- getsState scops let (oldBfsArr, oldBfsPath) = case bfsAndPathOld of BfsAndPath{bfsArr, bfsPath} -> (bfsArr, bfsPath) BfsInvalid -> error $ "" `showFailure` (bfsAndPathOld, aid, target) let bfsArr = oldBfsArr if not canMove then return (bfsArr, NoPath) else do b <- getsState $ getActorBody aid let lid = blid b seps <- getsClient seps salter <- getsClient salter lvl <- getLevel lid let !lalter = salter EM.! lid fovLit p = Tile.isLit coTileSpeedup $ lvl `at` p !source = bpos b !mpath = findPathBfs lalter fovLit source target seps bfsArr !bfsPath = EM.insert target mpath oldBfsPath bap = BfsAndPath{..} modifyClient $ \cli -> cli {sbfsD = EM.insert aid bap $ sbfsD cli} return (bfsArr, mpath) -- | Get cached BFS array and path or, if not stored, generate and store first. getCacheBfsAndPath :: forall m. MonadClient m => ActorId -> Point -> m (PointArray.Array BfsDistance, AndPath) getCacheBfsAndPath aid target = do mbfs <- getsClient $ EM.lookup aid . sbfsD case mbfs of Just bap@BfsAndPath{..} -> case EM.lookup target bfsPath of Nothing -> do (!canMove, _) <- condBFS aid updatePathFromBfs canMove bap aid target Just mpath -> return (bfsArr, mpath) _ -> do (!canMove, !alterSkill) <- condBFS aid !bfsArr <- createBfs canMove alterSkill aid let bfsPath = EM.empty updatePathFromBfs canMove BfsAndPath{..} aid target -- | Get cached BFS array or, if not stored, generate and store first. getCacheBfs :: MonadClient m => ActorId -> m (PointArray.Array BfsDistance) getCacheBfs aid = do mbfs <- getsClient $ EM.lookup aid . sbfsD case mbfs of Just BfsAndPath{bfsArr} -> return bfsArr _ -> do (!canMove, !alterSkill) <- condBFS aid !bfsArr <- createBfs canMove alterSkill aid let bfsPath = EM.empty modifyClient $ \cli -> cli {sbfsD = EM.insert aid BfsAndPath{..} (sbfsD cli)} return bfsArr -- | Get cached BFS path or, if not stored, generate and store first. getCachePath :: MonadClient m => ActorId -> Point -> m AndPath getCachePath aid target = do b <- getsState $ getActorBody aid let source = bpos b if | source == target -> return $! AndPath [] target 0 -- speedup | otherwise -> snd <$> getCacheBfsAndPath aid target createPath :: MonadClient m => ActorId -> Target -> m TgtAndPath createPath aid tapTgt = do COps{coTileSpeedup} <- getsState scops b <- getsState $ getActorBody aid lvl <- getLevel $ blid b let stopAtUnwalkable tapPath@AndPath{..} = let (walkable, rest) = -- Unknown tiles are not walkable, so path stops at first such. -- which is good, because by the time actor reaches the tile, -- it is known and target is recalculated with new info. span (Tile.isWalkable coTileSpeedup . at lvl) pathList in case rest of [] -> TgtAndPath{..} [g] | g == pathGoal -> TgtAndPath{..} newGoal : _ -> let newTgt = TPoint TKnown (blid b) newGoal newPath = AndPath{ pathList = walkable ++ [newGoal] , pathGoal = newGoal , pathLen = length walkable + 1 } in TgtAndPath{tapTgt = newTgt, tapPath = newPath} stopAtUnwalkable tapPath@NoPath = TgtAndPath{..} mpos <- getsState $ aidTgtToPos aid (blid b) tapTgt case mpos of Nothing -> return TgtAndPath{tapTgt, tapPath=NoPath} Just p -> do path <- getCachePath aid p return $! stopAtUnwalkable path condBFS :: MonadClient m => ActorId -> m (Bool, Word8) condBFS aid = do side <- getsClient sside -- We assume the actor eventually becomes a leader (or has the same -- set of 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. actorMaxSk <- maxActorSkillsClient aid let alterSkill = min (maxBound - 1) -- @maxBound :: Word8@ means unalterable (toEnum $ EM.findWithDefault 0 Ability.AbAlter actorMaxSk) canMove = EM.findWithDefault 0 Ability.AbMove actorMaxSk > 0 || EM.findWithDefault 0 Ability.AbDisplace actorMaxSk > 0 || EM.findWithDefault 0 Ability.AbProject actorMaxSk > 0 smarkSuspect <- getsClient smarkSuspect fact <- getsState $ (EM.! side) . sfactionD let underAI = isAIFact fact -- Under UI, playing a hero party, we let AI set our target each -- turn for henchmen that can't move and can't alter, usually to TUnknown. -- This is rather useless, but correct. enterSuspect = smarkSuspect > 0 || underAI skill | enterSuspect = alterSkill -- dig and search at will | otherwise = 1 -- only walkable tiles and unknown return (canMove, skill) -- keep it lazy -- | Furthest (wrt paths) known position. furthestKnown :: MonadClient m => ActorId -> m Point furthestKnown aid = do bfs <- getCacheBfs aid getMaxIndex <- rndToAction $ oneOf [ PointArray.maxIndexA , PointArray.maxLastIndexA ] let furthestPos = getMaxIndex bfs dist = bfs PointArray.! furthestPos return $! assert (dist > apartBfs `blame` (aid, furthestPos, dist)) furthestPos -- | Closest reachable unknown tile position, if any. -- -- Note: some of these tiles are behind suspect tiles and they are chosen -- in preference to more distant directly accessible unknown tiles. -- This is in principle OK, but in dungeons with few hidden doors -- AI is at a disadvantage (and with many hidden doors, it fares as well -- as a human that deduced the dungeon properties). Changing Bfs to accomodate -- all dungeon styles would be complex and would slow down the engine. -- -- If the level has inaccessible open areas (at least from the stairs AI used) -- the level will be nevertheless here finally marked 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. closestUnknown :: MonadClient m => ActorId -> m (Maybe Point) closestUnknown aid = do body <- getsState $ getActorBody aid lvl <- getLevel $ blid body bfs <- getCacheBfs aid let closestPoss = PointArray.minIndexesA bfs dist = bfs PointArray.! head closestPoss !_A = assert (lexpl lvl >= lseen lvl) () return $! if lexpl lvl <= lseen lvl -- Some unknown may still be visible and even pathable, but we already -- know from global level info that they are blocked. || dist >= apartBfs -- Global level info may tell us that terrain was changed and so -- some new explorable tile appeared, but we don't care about those -- and we know we already explored all initially seen unknown tiles -- and it's enough for us (otherwise we'd need to hunt all around -- the map for tiles altered by enemies). then Nothing else let unknownAround pos = let vic = vicinityUnsafe pos countUnknown :: Int -> Point -> Int countUnknown c p = if isUknownSpace $ lvl `at` p then c + 1 else c in foldl' countUnknown 0 vic cmp = comparing unknownAround in Just $ maximumBy cmp closestPoss -- | Finds smells closest to the actor, except under the actor, -- because actors consume smell only moving over them, not standing. -- Of the closest, prefers the newest smell. closestSmell :: MonadClient m => ActorId -> m [(Int, (Point, Time))] closestSmell aid = do body <- getsState $ getActorBody aid Level{lsmell, ltime} <- getLevel $ blid body let smells = filter (\(p, sm) -> sm > ltime && p /= bpos body) (EM.assocs lsmell) case smells of [] -> return [] _ -> do bfs <- getCacheBfs aid let ts = mapMaybe (\x@(p, _) -> fmap (,x) (accessBfs bfs p)) smells return $! sortBy (comparing (fst &&& absoluteTimeNegate . snd . snd)) ts data FleeViaStairsOrEscape = ViaStairs | ViaStairsUp | ViaStairsDown | ViaEscape | ViaNothing | ViaAnything deriving (Show, Eq) embedBenefit :: MonadClient m => FleeViaStairsOrEscape -> ActorId -> [(Point, ItemBag)] -> m [(Double, (Point, ItemBag))] embedBenefit fleeVia aid pbags = do COps{coTileSpeedup} <- getsState scops dungeon <- getsState sdungeon explored <- getsClient sexplored b <- getsState $ getActorBody aid actorSk <- if fleeVia == ViaAnything -- targeting, e.g., when not a leader then maxActorSkillsClient aid else currentSkillsClient aid let alterSkill = EM.findWithDefault 0 Ability.AbAlter actorSk fact <- getsState $ (EM.! bfid b) . sfactionD lvl <- getLevel (blid b) unexploredTrue <- unexploredDepth True (blid b) unexploredFalse <- unexploredDepth False (blid b) condEnoughGear <- condEnoughGearM aid discoBenefit <- getsClient sdiscoBenefit getKind <- getsState $ flip getIidKind let alterMinSkill p = Tile.alterMinSkill coTileSpeedup $ lvl `at` p lidExplored = ES.member (blid b) explored allExplored = ES.size explored == EM.size dungeon -- Ignoring the number of items, because only one of each @iid@ -- is triggered at the same time, others are left to be used later on. -- Taking the kind the item hides under into consideration, because -- it's a best guess only, for AI and UI. iidToEffs iid = IK.ieffects $ getKind iid feats bag = concatMap iidToEffs $ EM.keys bag -- For simplicity, we assume at most one exit at each position. -- AI uses exit regardless of traps or treasures at the spot. bens (_, bag) = case find IK.isEffEscapeOrAscend $ feats bag of Just IK.Escape{} -> -- Escape (or guard) only after exploring, for high score, etc. let escapeOrGuard = fcanEscape (gplayer fact) || fleeVia == ViaAnything -- targeting to guard in if fleeVia `elem` [ViaEscape, ViaAnything] && escapeOrGuard && allExplored then 10 else 0 -- don't escape prematurely Just (IK.Ascend up) -> -- change levels sensibly, in teams let easier = up /= (fromEnum (blid b) > 0) unexpForth = if up then unexploredTrue else unexploredFalse unexpBack = if not up then unexploredTrue else unexploredFalse -- Forbid loops via peeking at unexplored and getting back. aiCond = if unexpForth then easier && condEnoughGear || (not unexpBack || easier) && lidExplored else easier && allExplored && null (lescape lvl) -- Prefer one direction of stairs, to team up -- and prefer embed (may, e.g., create loot) over stairs. v = if aiCond then if easier then 10 else 1 else 0 in case fleeVia of ViaStairsUp | up -> 1 ViaStairsDown | not up -> 1 ViaStairs -> v ViaAnything -> v _ -> 0 -- don't ascend prematurely _ -> if fleeVia `elem` [ViaNothing, ViaAnything] then -- Actor uses the embedded item on himself, hence @effApply@. -- Let distance be the deciding factor and also prevent -- overflow on 32-bit machines. min 1000 $ sum $ map (\iid -> benApply $ discoBenefit EM.! iid) (EM.keys bag) else 0 interestingHere p = -- For speed and to avoid greedy AI loops, filter targets. Tile.consideredByAI coTileSpeedup (lvl `at` p) -- Only actors with high enough AbAlter can trigger embedded items. && alterSkill >= fromEnum (alterMinSkill p) ebags = filter (interestingHere . fst) pbags benFeats = map (\pbag -> (bens pbag, pbag)) ebags return $! filter ((> 0 ) . fst) benFeats -- | Closest (wrt paths) AI-triggerable tiles with embedded items. -- In AI, the level the actor is on is either explored or the actor already -- has a weapon equipped, so no need to explore further, he tries to find -- enemies on other levels, but before that, he triggers other tiles -- in hope of some loot or beneficial effect to enter next level with. closestTriggers :: MonadClient m => FleeViaStairsOrEscape -> ActorId -> m [(Int, (Point, (Point, ItemBag)))] closestTriggers fleeVia aid = do b <- getsState $ getActorBody aid lvl <- getLevel (blid b) let pbags = EM.assocs $ lembed lvl efeat <- embedBenefit fleeVia aid pbags -- The advantage of targeting the tiles in vicinity of triggers is that -- triggers don't need to be pathable (and so AI doesn't bump into them -- by chance while walking elsewhere) and that many accesses to the tiles -- are more likely to be targeted by different AI actors (even starting -- from the same location), so there is less risk of clogging stairs and, -- OTOH, siege of stairs or escapes is more effective. bfs <- getCacheBfs aid let vicTrigger (cid, (p0, bag)) = map (\p -> (cid, (p, (p0, bag)))) $ vicinityUnsafe p0 vicAll = concatMap vicTrigger efeat return $ -- keep lazy let mix (benefit, ppbag) dist = let maxd = fromEnum maxBfsDistance - fromEnum apartBfs v = (fromIntegral maxd * 10) / (fromIntegral dist + 1) in (ceiling $ benefit * v, ppbag) in mapMaybe (\bpp@(_, (p, _)) -> mix bpp <$> accessBfs bfs p) vicAll -- | Check whether the actor has enough gear to go look for enemies. -- We assume weapons in equipment are better than any among organs -- or at least provide some essential diversity. -- Disabled if, due to tactic, actors follow leader and so would -- repeatedly move towards and away form stairs at leader change, -- depending on current leader's gear. -- Number of items of a single kind is ignored, because variety is needed. condEnoughGearM :: MonadClient m => ActorId -> m Bool condEnoughGearM aid = do b <- getsState $ getActorBody aid fact <- getsState $ (EM.! bfid b) . sfactionD let followTactic = ftactic (gplayer fact) `elem` [TFollow, TFollowNoItems] eqpAssocs <- getsState $ fullAssocs aid [CEqp] invAssocs <- getsState $ getActorAssocs aid CInv return $ not followTactic -- keep it lazy && (any (IK.isMelee . itemKind . snd) eqpAssocs || length eqpAssocs + length invAssocs >= 5) unexploredDepth :: MonadClient m => Bool -> LevelId -> m Bool unexploredDepth !up !lidCurrent = do dungeon <- getsState sdungeon explored <- getsClient sexplored let allExplored = ES.size explored == EM.size dungeon unexploredD = let unex !lid = allExplored && not (null $ lescape $ dungeon EM.! lid) || ES.notMember lid explored || unexploredD lid in any unex . ascendInBranch dungeon up return $ unexploredD lidCurrent -- keep it lazy -- | Closest (wrt paths) items. closestItems :: MonadClient m => ActorId -> m [(Int, (Point, ItemBag))] closestItems aid = do actorMaxSk <- maxActorSkillsClient aid if EM.findWithDefault 0 Ability.AbMoveItem actorMaxSk <= 0 then return [] else do body <- getsState $ getActorBody aid Level{lfloor} <- getLevel $ blid body if EM.null lfloor then return [] else do bfs <- getCacheBfs aid let mix pbag dist = let maxd = fromEnum maxBfsDistance - fromEnum apartBfs -- Bewqre of overflowing 32-bit integers here. -- Here distance is the only factor influencing frequency, -- unless item not desirable, which is checked later on. v = (maxd * 10) `div` (dist + 1) in (v, pbag) return $! mapMaybe (\(p, bag) -> mix (p, bag) <$> accessBfs bfs p) (EM.assocs lfloor) -- | 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.8.3.0/Game/LambdaHack/Client/Preferences.hs0000644000000000000000000006276013315545734020675 0ustar0000000000000000-- | Actor preferences for targets and actions, based on actor attributes. module Game.LambdaHack.Client.Preferences ( totalUsefulness #ifdef EXPOSE_INTERNAL -- * Internal operations , effectToBenefit , averageTurnValue, avgItemDelay, avgItemLife, durabilityMult , organBenefit, recBenefit, fakeItem, aspectToBenefit, recordToBenefit #endif ) where import Prelude () import Game.LambdaHack.Common.Prelude import qualified Game.LambdaHack.Common.Dice as Dice import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.Flavour import Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.ItemAspect as IA import Game.LambdaHack.Common.Kind import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.Time import Game.LambdaHack.Content.ItemKind (ItemKind) import qualified Game.LambdaHack.Content.ItemKind as IK import Game.LambdaHack.Content.ModeKind -- | How much AI benefits from applying the effect. -- The first component is benefit when applied to self, the second -- is benefit (preferably negative) when applied to enemy. -- This represents benefit from using the effect every @avgItemDelay@ turns, -- so if the item is not durable, the value is adjusted down elsewhere. -- The benefit includes the drawback of having to use the actor's turn, -- except when there is battle and item is a weapon and so there is usually -- nothing better to do than to melee, or when the actor is stuck or idle -- or laying in wait or luring an enemy from a safe distance. -- So there is less than @averageTurnValue@ included in each benefit, -- so in case when turn is not spent, e.g, periodic or conditions, -- the difference in value is only slight. effectToBenefit :: COps -> Faction -> Bool -> IK.Effect -> (Double, Double) effectToBenefit cops fact insideRecharging eff = let delta x = (x, x) in case eff of IK.Burn d -> delta $ -(min 1500 $ 15 * Dice.meanDice d) -- often splash damage, armor doesn't block (but HurtMelee doesn't boost) IK.Explode _ | insideRecharging -> -- It's too hard to analyze, so we assume, explosion inside recharging -- is never a cruel and cheap one-time trap, damaging HP of the actor -- before he identifies the item and stops wearing it or meleeing with it. -- So the explosion is either both focused and beneficial to self -- or is not focused and so not affecting self. In either case -- it can be good or bad for nearby friends and foes and, regardless, -- AI chooses to equip that item, for fun and to challenge human player -- with varied situations. ( 1 -- equip, but not too greedily, in case it mostly harms friends , -1 ) -- hit with it or throw, but beware of harming friends IK.Explode "single spark" -> delta (-1) -- hardwired; probing and flavour IK.Explode _ -> -- We know this explosion is not wrapped with @Recharging@ nor @OnSmash@ -- so we assume it's focused and very harmful and so only safe -- for projecting at foes. Due to this assumption healing explosives -- should be wrapped to avoid throwing them at foes. delta (-100) IK.RefillHP p -> delta $ if p > 0 then min 2000 (20 * fromIntegral p) else max (-1000) (10 * fromIntegral p) -- one HP healed is worth a bit more than one HP dealed to enemy, -- because if the actor survives, he may deal damage many times; -- however, AI is mostly for non-heroes that fight in suicidal crowds, -- so the two values are kept close enough to maintain berserk approach IK.RefillCalm p -> delta $ if p > 0 then min 9 (fromIntegral p) else max (-9) (fromIntegral p) IK.Dominate -> (0, -300) -- I obtained an actor with, say 10HP, -- worth 200, and enemy lost him, another 100 IK.Impress -> (10, -50) -- can affect friends, but more often enemies, -- hence it's considered harmful when thrown IK.Summon grp d -> -- contrived by not taking into account alliances -- and not checking if enemies also control that group let ben = Dice.meanDice d * 200 -- the new actor can have, say, 10HP in if grp `elem` fgroups (gplayer fact) then (ben, -1) else (-ben, 1) -- prefer applying to flinging summoning items; further, but more robust IK.Ascend{} -> (-99, 99) -- note the reversed values: -- only change levels sensibly, in teams, -- and don't remove enemy too far, he may be -- easy to kill and may have loot IK.Escape{} -> (-9999, 9999) -- even if can escape, loots first and then -- handles escape as a special case -- The following two are expensive, because they ofen activate -- while in melee, in which case each turn is worth x HP, where x -- is the average effective weapon damage in the game, which would -- be ~5. (Plus a huge risk factor for any non-spawner faction.) -- So, each turn in battle is worth ~100. And on average, in and out -- of battle, let's say each turn is worth ~10. IK.Paralyze d -> delta $ -20 * Dice.meanDice d -- clips IK.InsertMove d -> delta $ 100 * Dice.meanDice d -- turns IK.Teleport d -> if Dice.meanDice d <= 8 then (1, 0) -- blink to shoot at foes else (-9, -1) -- for self, don't derail exploration -- for foes, fight with one less at a time IK.CreateItem COrgan "condition" _ -> (1, -1) -- varied, big bunch, but try to create it anyway IK.CreateItem COrgan grp timer -> -- assumed temporary let noneResult = averageTurnValue + 1 -- copy count used instead turnTimer = IK.foldTimer noneResult Dice.meanDice Dice.meanDice timer (total, count) = organBenefit turnTimer grp cops fact in delta $ total / fromIntegral count -- the same when created in me and in foe -- average over all matching grps; simplified: rarities ignored IK.CreateItem _ "treasure" _ -> (100, 0) -- assumed not temporary IK.CreateItem _ "common item" _ -> (70, 0) IK.CreateItem _ "curious item" _ -> (70, 0) IK.CreateItem _ "any scroll" _ -> (50, 0) IK.CreateItem _ "any vial" _ -> (50, 0) IK.CreateItem _ "potion" _ -> (50, 0) IK.CreateItem _ "explosive" _ -> (50, 0) IK.CreateItem _ "any jewelry" _ -> (100, 0) IK.CreateItem _ grp _ -> -- assumed not temporary and @grp@ tiny let (total, count) = recBenefit grp cops fact in (total / fromIntegral count, 0) IK.DropItem _ _ COrgan "condition" -> delta 30 -- save for curing own bad conditions IK.DropItem ngroup kcopy COrgan grp -> -- assumed temporary -- Simplified: we assume actor has an average number of copies -- (and none have yet run out, e.g., prompt curing of poisoning) -- of a single kind of organ (and so @ngroup@ doesn't matter) -- of average benefit and that @kcopy@ is such that all copies -- are dropped. Separately we add bonuses for @ngroup@ and @kcopy@. -- Remaining time of the organ is arbitrarily assumed to be 20 turns. let turnTimer = 20 (total, count) = organBenefit turnTimer grp cops fact boundBonus n = if n == maxBound then 10 else 0 in delta $ boundBonus ngroup + boundBonus kcopy - total / fromIntegral count -- the same when dropped from me and foe IK.DropItem{} -> delta (-10) -- depends a lot on what is dropped IK.PolyItem -> (1, 0) -- may fizzle, so AI never uses (could loop) IK.Identify -> (1, 0) -- may fizzle, so AI never uses (could loop) IK.Detect IK.DetectAll radius -> (fromIntegral radius * 2, 0) IK.Detect _ radius -> (fromIntegral radius, 0) IK.SendFlying _ -> (1, -100) -- very context dependent, but it's better IK.PushActor _ -> (1, -100) -- to be the one that decides whether to fly; IK.PullActor _ -> (1, -100) -- pushing others may crush them against wall IK.DropBestWeapon -> delta $ -50 -- often a whole turn wasted == InsertMove IK.ActivateInv ' ' -> delta $ -200 -- brutal and deadly IK.ActivateInv _ -> delta $ -50 -- depends on the items IK.ApplyPerfume -> delta 0 -- depends on smell sense of friends and foes IK.OneOf efs -> let bs = map (effectToBenefit cops fact insideRecharging) efs f (self, foe) (accSelf, accFoe) = (self + accSelf, foe + accFoe) (effSelf, effFoe) = foldr f (0, 0) bs in (effSelf / fromIntegral (length bs), effFoe / fromIntegral (length bs)) IK.OnSmash _ -> delta 0 -- can be beneficial; we'd need to analyze explosions, range, etc. IK.Recharging _ -> delta 0 -- taken into account separately IK.Temporary _ -> delta 0 -- assumed for created organs only IK.Composite [] -> delta 0 IK.Composite (eff1 : _) -> effectToBenefit cops fact insideRecharging eff1 -- for simplicity; so in content make sure to place initial animations -- among normal effects, not at the start of composite effect -- (animations should not fail, after all), and start composite -- effect with the main thing -- See the comment for @Paralyze@. averageTurnValue :: Double averageTurnValue = 10 -- Average delay between desired item uses. Some items are best activated -- every turn, e.g., healing (but still, on average, the activation would be -- useless some of the time, namely when HP is at max, which is rare, -- or when some combat boost is already lasting, which is probably also rare). -- However, e.g., for detection, activating every few turns is enough. -- Also, sometimes actor has many activable items, so he doesn't want to use -- the less powerful ones as often as when they are alone. -- For weapons, it depends. Sometimes a weapon with disorienting effect -- should be used once every couple of turns and stronger raw damage -- weapons all the remaining time. In other cases a single weapon -- with a devastating effect would ideally be available each turn. -- We don't want to undervalue rarely used items with long timeouts -- and we think that most interesting gameplay comes from alternating -- item use, so we arbitrarily set the full value timeout to 3. avgItemDelay :: Double avgItemDelay = 3 -- The average time between item being found (and enough skill obtained -- to use it) and item not being used any more. We specifically ignore -- item not being used any more, because it is not durable and is consumed. -- However we do consider actor mortality (especially common for spawners) -- and item contending with many other very different but valuable items -- that all vie for the same turn needed to activate them (especially common -- for non-spawners). Another reason is item getting obsolete or duplicated, -- by finding a strictly better item or an identical item. -- The @avgItemLife@ constant only makes sense for items with non-periodic -- effects, because the effects' benefit is not cumulative -- by just placing them in equipment and they cost a turn to activate. -- We set the value to 30, assuming if the actor finds an item, then he is -- most likely at an unlooted level, so he will find more loot soon, -- or he is in a battle, so he will die soon (or win even more loot). avgItemLife :: Double avgItemLife = 30 -- The value of durable item is this many times higher than non-durable, -- because the item will on average be activated this many times -- before it stops being used. durabilityMult :: Double durabilityMult = avgItemLife / avgItemDelay -- We assume the organ is temporary (@Temporary@, @Periodic@, @Timeout 0@) -- and also that it doesn't provide any functionality, e.g., detection -- or burning or raw damage. However, we take into account recharging -- effects, knowing in some temporary organs, e.g., poison or regeneration, -- they are triggered at each item copy destruction. They are applied to self, -- hence we take the self component of valuation. We multiply by the count -- of created/dropped organs, because for conditions it determines -- how many times the effect is applied, before the last copy expires. -- -- The temporary organs are not durable nor in infnite copies, so to give -- continous benefit, organ has to be recreated each @turnTimer@ turns. -- Creation takes a turn, so incurs @averageTurnValue@ cost. -- That's how the lack of durability impacts their value, not via -- @durabilityMult@, which however may be applied to organ creating item. -- So, on average, maintaining the organ costs @averageTurnValue/turnTimer@. -- So, if an item lasts @averageTurnValue@ and it can be created at will, -- it's as valuable as permanent. This makes sense even if the item creating -- the organ is not durable, but the timer is huge. One may think the lack -- of durability should be offset by the timer, but remember that average -- item life @avgItemLife@ is rather low, so either a new item will be found -- soon and so the long timer doesn't matter or the actor will die -- or the gameplay context will change (e.g., out of battle) and so the effect -- will no longer be useful. -- -- When considering the effects, we just use their standard valuation, -- despite them not using up actor's turn to be applied each turn, -- because, similarly as for periodic items, we don't control when they -- are applied and we can't stop/restart them. -- -- We assume, only one of timer and count mechanisms is present at once. -- We assume no organ has effect that drops its group or creates its group; -- otherwise we'd loop. organBenefit :: Double -> GroupName ItemKind -> COps -> Faction -> (Double, Int) organBenefit turnTimer grp cops@COps{coitem} fact = let f (!sacc, !pacc) !p _ !kind = let paspect asp = fromIntegral p * aspectToBenefit asp peffect eff = fromIntegral p * fst (effectToBenefit cops fact False eff) in ( sacc + Dice.meanDice (IK.icount kind) * (sum (map paspect $ IK.iaspects kind) + sum (map peffect $ IK.stripRecharging $ IK.ieffects kind)) - averageTurnValue / turnTimer , pacc + p ) in ofoldlGroup' coitem grp f (0, 0) -- We assume no item has effect that drops its group or creates its group; -- otherwise we'd loop. recBenefit :: GroupName ItemKind -> COps -> Faction -> (Double, Int) recBenefit grp cops@COps{coitem, coItemSpeedup} fact = let f (!sacc, !pacc) !p !kindId !kind = let km = IK.getKindMean kindId coItemSpeedup recPickup = benPickup $ totalUsefulness cops fact (fakeItem kindId kind km) in ( sacc + Dice.meanDice (IK.icount kind) * recPickup , pacc + p ) in ofoldlGroup' coitem grp f (0, 0) fakeItem :: ContentId IK.ItemKind -> IK.ItemKind -> IA.KindMean -> ItemFull fakeItem kindId kind km = let jkind = IdentityObvious kindId jlid = toEnum 1 -- dummy jfid = Nothing -- the default jflavour = Flavour minBound minBound -- dummy itemBase = Item{..} itemDisco = ItemDiscoMean km in ItemFull itemBase kindId kind itemDisco True -- Value of aspects and effects is linked by some deep economic principles -- which I'm unfortunately ignorant of. E.g., average weapon hits for 5HP, -- so it's worth 50 per turn, so that should also be the worth per turn -- of equpping a sword oil that doubles damage via @AddHurtMelee@. -- Which almost matches up, since 100% effective oil is worth 100. -- Perhaps oil is worth double (despite cap, etc.), because it's addictive -- and raw weapon damage is not; so oil stays and old weapons get trashed. -- However, using the weapon in combat costs 100 (the value of extra -- battle turn). However, one turn per turn is almost free, because something -- has to be done to move the time forward. If the oil required wasting a turn -- to affect next strike, then we'd have two turns per turn, so the cost -- would be real and 100% oil would not have any significant good or bad effect -- any more, but 200% oil (if not for the cap) would still be worth it. -- -- Anyway, that suggests that the current scaling of effect vs aspect values -- is reasonable. What is even more important is consistency among aspects -- so that, e.g., a shield or a torch is neven equipped, but oil lamp is. -- Valuation of effects, and more precisely, more the signs than absolute -- values, ensures that both shield and torch get picked up so that -- the (human) actor can nevertheless equip them in very special cases. aspectToBenefit :: IA.Aspect -> Double aspectToBenefit asp = case asp of IA.Timeout{} -> 0 IA.AddHurtMelee p -> Dice.meanDice p -- offence favoured IA.AddArmorMelee p -> Dice.meanDice p / 4 -- only partial protection IA.AddArmorRanged p -> Dice.meanDice p / 8 IA.AddMaxHP p -> Dice.meanDice p IA.AddMaxCalm p -> Dice.meanDice p / 5 IA.AddSpeed p -> Dice.meanDice p * 25 -- 1 speed ~ 5% melee; times 5 for no caps, escape, pillar-dancing, etc.; -- also, it's 1 extra turn each 20 turns, so 100/20, so 5; figures IA.AddSight p -> Dice.meanDice p * 5 IA.AddSmell p -> Dice.meanDice p IA.AddShine p -> Dice.meanDice p * 2 IA.AddNocto p -> Dice.meanDice p * 10 -- > sight + light; stealth, slots IA.AddAggression{} -> 0 IA.AddAbility _ p -> Dice.meanDice p * 5 recordToBenefit :: IA.AspectRecord -> [Double] recordToBenefit aspects = map aspectToBenefit $ IA.aspectRecordToList aspects -- | Compute the whole 'Benefit' structure, containing various facets -- of AI item preference, for an item with the given effects and aspects. -- -- Note: result has non-strict fields, so arguments are forced to avoid leaks. -- When AI looks at items (including organs) more often, force the fields. totalUsefulness :: COps -> Faction -> ItemFull -> Benefit totalUsefulness !cops !fact itemFull@ItemFull{itemKind, itemSuspect} = let effects = IK.ieffects itemKind aspects = aspectRecordFull itemFull effPairs = map (effectToBenefit cops fact False) effects effDice = - IK.damageUsefulness itemKind f (self, foe) (accSelf, accFoe) = (self + accSelf, foe + accFoe) (effSelf, effFoe) = foldr f (0, 0) effPairs -- Timeout between 0 and 1 means item usable each turn, so we consider -- it equivalent to a permanent item --- without timeout restriction. -- Timeout 2 means two such items are needed to use the effect each turn, -- so a single such item may be worth half of the permanet value. -- Hence, we multiply item value by the proportion of the average desired -- delay between item uses @avgItemDelay@ and the actual timeout. timeout = IA.aTimeout aspects (chargeSelf, chargeFoe) = let scaleChargeBens bens | timeout <= 3 = bens | otherwise = map (\eff -> if avgItemDelay >= fromIntegral timeout then eff else eff * avgItemDelay / fromIntegral timeout) bens (cself, cfoe) = unzip $ map (effectToBenefit cops fact True) (IK.stripRecharging effects) in (scaleChargeBens cself, scaleChargeBens cfoe) -- If the item is periodic, we add charging effects to equipment benefit, -- but we don't assign periodic bonus or malus, because periodic items -- are bad in that one can't activate them at will and they take -- equipment space, and good in that one saves a turn, not having -- to manually activate them. Additionally, no weapon can be periodic, -- because damage would be applied to the fighter, so a large class -- of items with timeout is excluded from the consideration. -- Generally, periodic seems more helpful on items with low timeout -- and obviously beneficial effects, e.g., frequent periodic healing -- or nearby detection is better, but infrequent periodic teleportation -- or harmful explosion is worse. But the rule is not strict and also -- dependent on gameplay context of the moment, hence no numerical value. periodic = IK.Periodic `elem` IK.ifeature itemKind -- Durability doesn't have any numerical impact to @eqpSum, -- because item is never consumed by just being stored in equipment. -- Also no numerical impact for flinging, because we can't fling it again -- in the same skirmish and also enemy can pick up and fling back. -- Only @benMelee@ and @benApply@ are affected, regardless if the item -- is in equipment or not. As summands of @benPickup@ they should be -- impacted by durability, because picking an item to be used -- only once is less advantageous than when the item is durable. -- For deciding which item to apply or melee with, they should be -- impacted, because it makes more sense to use an item that is durable -- and save the option for using non-durable item for the future, e.g., -- when both items have timeouts, starting with durable is beneficial, -- because it recharges while the non-durable is prepared and used. durable = IK.Durable `elem` IK.ifeature itemKind -- If recharging effects not periodic, we add the self part, -- because they are applied to self. If they are periodic we can't -- effectively apply them, because they are never recharged, -- because they activate as soon as recharged. benApply = max 0 $ -- because optional; I don't need to apply (effSelf + effDice -- hits self with dice too, when applying + if periodic then 0 else sum chargeSelf) / if durable then 1 else durabilityMult -- For melee, we add the foe part. benMelee = min 0 $ (effFoe + effDice -- @AddHurtMelee@ already in @eqpSum@ + if periodic then 0 else sum chargeFoe) / if durable then 1 else durabilityMult -- Experimenting is fun, but it's better to risk foes' skin than ours, -- so we only adjust flinging bonus, not apply bonus. It's also more -- fun gameplay-wise when enemies throw at us rather than using items. benFling = min benFlingRaw $ if itemSuspect then -10 else 0 -- The periodic effects, if any, are activated when projectile flies, -- but not when it hits, so they are not added to @benFling@. -- However, if item is not periodic, the recharging effects -- are activated at projectile impact, hence their value is added. benFlingRaw = min 0 $ effFoe + benFlingDice -- nothing in @eqpSum@; normally not worn + if periodic then 0 else sum chargeFoe benFlingDice | IK.idamage itemKind == 0 = 0 -- speedup | otherwise = assert (v <= 0) v where hurtMult = 100 + min 99 (max (-99) (IA.aHurtMelee aspects)) -- assumes no enemy armor and no block dmg = Dice.meanDice $ IK.idamage itemKind rawDeltaHP = ceiling $ fromIntegral hurtMult * xD dmg / 100 -- For simplicity, we ignore range bonus/malus and @Lobable@. IK.ThrowMod{IK.throwVelocity} = IK.getToThrow itemKind speed = speedFromWeight (IK.iweight itemKind) throwVelocity v = - fromIntegral (modifyDamageBySpeed rawDeltaHP speed) * 10 / xD 1 -- 1 damage valued at 10, just as in @damageUsefulness@ -- For equipment benefit, we take into account only the self -- value of the recharging effects, because they applied to self. -- We don't add a bonus @averageTurnValue@ to the value of periodic -- effects, even though they save a turn, by being auto-applied, -- because on the flip side, player is not in control of the precise -- timing of their activation and also occasionally needs to spend a turn -- unequipping them to prevent activation. Note also that periodic -- activations don't consume the item, whether it's durable or not. eqpBens = recordToBenefit aspects ++ if periodic then chargeSelf else [] sumBens = sum eqpBens -- Equipped items may incur crippling maluses via aspects and periodic -- effects. Examples of crippling maluses are, e.g., such that make melee -- impossible or moving impossible. AI can't live with those and can't -- value those competently against bonuses the item provides. cripplingDrawback = not (null eqpBens) && minimum eqpBens < -20 eqpSum = sumBens - if cripplingDrawback then 100 else 0 -- If a weapon heals enemy at impact, it won't be used for melee -- (but can be equipped anyway). If it harms wearer too much, -- won't be worn but still may be flung, etc. (benInEqp, benPickupRaw) | IK.isMelee itemKind -- probably known even if not identified && (benMelee < 0 || itemSuspect) && eqpSum >= -20 = ( True -- equip, melee crucial, and only weapons in eqp can be used , if durable then eqpSum + max benApply (- benMelee) -- apply or melee or not else - benMelee) -- melee is predominant | (IK.goesIntoEqp itemKind || IK.isTmpCondition itemKind) -- hack to record benefit && (eqpSum > 0 || itemSuspect) = -- weapon or other equippable ( True -- equip; long time bonus usually outweighs fling or apply , eqpSum -- possibly spent turn equipping, so reap the benefits + if durable then benApply -- apply or not but don't fling else 0) -- don't remove from equipment by using up | otherwise = (False, max benApply (- benFling)) -- apply or fling benPickup = max benPickupRaw $ if itemSuspect then 10 else 0 in Benefit{..} LambdaHack-0.8.3.0/Game/LambdaHack/Client/ClientOptions.hs0000644000000000000000000000613413315545734021217 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} -- | Options that affect the behaviour of the client. module Game.LambdaHack.Client.ClientOptions ( ClientOptions(..), defClientOptions ) where import Prelude () import Game.LambdaHack.Common.Prelude import Data.Binary import GHC.Generics (Generic) -- | Options that affect the behaviour of the client (but not game rules). data ClientOptions = ClientOptions { sgtkFontFamily :: Maybe Text -- ^ Font family to use for the GTK main game window. , sdlFontFile :: Maybe Text -- ^ Font file to use for the SDL2 main game window. , sdlTtfSizeAdd :: Maybe Int -- ^ Pixels to add to map cells on top of scalable font max glyph height. , sdlFonSizeAdd :: Maybe Int -- ^ Pixels to add to map cells on top of .fon font max glyph height. , sfontSize :: Maybe Int -- ^ Font size to use for the main game window. , scolorIsBold :: Maybe Bool -- ^ Whether to use bold attribute for colorful characters. , slogPriority :: Maybe Int -- ^ How much to log (e.g., from SDL). 1 is all, 5 is errors, the default. , 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. , 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. , stitle :: Maybe Text , sfontDir :: Maybe FilePath , ssavePrefixCli :: String -- ^ Prefix of the save game file name. , sfrontendTeletype :: Bool -- ^ Whether to use the stdout/stdin frontend. , sfrontendNull :: Bool -- ^ Whether to use null (no input/output) frontend. , sfrontendLazy :: Bool -- ^ Whether to use lazy (output not even calculated) frontend. , sdbgMsgCli :: Bool -- ^ Show clients' internal debug messages. , sstopAfterSeconds :: Maybe Int , sstopAfterFrames :: Maybe Int , sprintEachScreen :: Bool } deriving (Show, Eq, Generic) instance Binary ClientOptions -- | Default value of client options. defClientOptions :: ClientOptions defClientOptions = ClientOptions { sgtkFontFamily = Nothing , sdlFontFile = Nothing , sdlTtfSizeAdd = Nothing , sdlFonSizeAdd = Nothing , sfontSize = Nothing , scolorIsBold = Nothing , slogPriority = Nothing , smaxFps = Nothing , sdisableAutoYes = False , snoAnim = Nothing , snewGameCli = False , sbenchmark = False , stitle = Nothing , sfontDir = Nothing , ssavePrefixCli = "" , sfrontendTeletype = False , sfrontendNull = False , sfrontendLazy = False , sdbgMsgCli = False , sstopAfterSeconds = Nothing , sstopAfterFrames = Nothing , sprintEachScreen = False } LambdaHack-0.8.3.0/Game/LambdaHack/Client/Response.hs0000644000000000000000000000222313315545734020216 0ustar0000000000000000-- | Abstract syntax of responses. -- -- See -- . module Game.LambdaHack.Client.Response ( Response(..) ) where import Prelude () import Game.LambdaHack.Common.Prelude import Game.LambdaHack.Atomic import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.State -- | Abstract syntax of responses sent by server to an AI or UI client -- (or a universal client that can handle both roles, which is why -- this type is not separated into distinct AI and UI types). -- A response tells a client how to update game state or what information -- to send to the server. data Response = RespUpdAtomicNoState UpdAtomic -- ^ change @State@ by performing this atomic update | RespUpdAtomic State UpdAtomic -- ^ put the given @State@, which results from performing the atomic update | RespQueryAI ActorId -- ^ compute an AI move for the actor and send (the semantics of) it | RespSfxAtomic SfxAtomic -- ^ perform special effects (animations, messages, etc.) | RespQueryUI -- ^ prompt the human player for a command and send (the semantics of) it deriving Show LambdaHack-0.8.3.0/Game/LambdaHack/Client/AI/0000755000000000000000000000000013315545734016356 5ustar0000000000000000LambdaHack-0.8.3.0/Game/LambdaHack/Client/AI/PickTargetM.hs0000644000000000000000000005402113315545734021066 0ustar0000000000000000{-# LANGUAGE TupleSections #-} -- | Let AI pick the best target for an actor. module Game.LambdaHack.Client.AI.PickTargetM ( refreshTarget #ifdef EXPOSE_INTERNAL -- * Internal operations , computeTarget #endif ) where import Prelude () import Game.LambdaHack.Common.Prelude import qualified Data.EnumMap.Lazy as LEM import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES import Game.LambdaHack.Client.AI.ConditionM import Game.LambdaHack.Client.Bfs import Game.LambdaHack.Client.BfsM import Game.LambdaHack.Client.CommonM import Game.LambdaHack.Client.MonadClient import Game.LambdaHack.Client.State import Game.LambdaHack.Common.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 qualified Game.LambdaHack.Common.ItemAspect as IA import Game.LambdaHack.Common.Kind import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.MonadStateRead import Game.LambdaHack.Common.Point import qualified Game.LambdaHack.Common.PointArray as PointArray import Game.LambdaHack.Common.Random import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile import Game.LambdaHack.Common.Time import Game.LambdaHack.Common.Vector import Game.LambdaHack.Content.ModeKind import Game.LambdaHack.Content.RuleKind import Game.LambdaHack.Content.TileKind (isUknownSpace) -- | 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) -> m (Maybe TgtAndPath) -- This inline speeds up execution by 5% and decreases allocation by 10%, -- despite probably bloating executable: {-# INLINE refreshTarget #-} refreshTarget (aid, body) = do side <- getsClient sside let !_A = assert (bfid body == side `blame` "AI tries to move an enemy actor" `swith` (aid, body, side)) () let !_A = assert (isNothing (btrajectory body) && not (bproj body) `blame` "AI gets to manually move its trajectory actors" `swith` (aid, body, side)) () mtarget <- computeTarget aid case mtarget of Nothing -> do -- Melee in progress and the actor can't contribute -- and would slow down others if he acted. modifyClient $ \cli -> cli {stargetD = EM.delete aid (stargetD cli)} return Nothing Just tgtMPath -> do -- _debugoldTgt <- getsClient $ EM.lookup aid . stargetD -- Choose a target from those proposed by AI for the actor. modifyClient $ \cli -> cli {stargetD = EM.insert aid tgtMPath (stargetD cli)} return mtarget -- let _debug = T.unpack -- $ "\nHandleAI symbol:" <+> tshow (bsymbol body) -- <> ", aid:" <+> tshow aid -- <> ", pos:" <+> tshow (bpos body) -- <> "\nHandleAI oldTgt:" <+> tshow _debugoldTgt -- <> "\nHandleAI strTgt:" <+> tshow stratTarget -- <> "\nHandleAI target:" <+> tshow tgtMPath -- trace _debug $ return $ Just tgtMPath computeTarget :: forall m. MonadClient m => ActorId -> m (Maybe TgtAndPath) {-# INLINE computeTarget #-} computeTarget aid = do cops@COps{coTileSpeedup} <- getsState scops b <- getsState $ getActorBody aid mleader <- getsClient sleader scondInMelee <- getsClient scondInMelee salter <- getsClient salter -- We assume the actor eventually becomes a leader (or has the same -- set of abilities as the leader, anyway) and set his target accordingly. actorAspect <- getsState sactorAspect let lalter = salter EM.! blid b condInMelee = scondInMelee LEM.! blid b stdRuleset = getStdRuleset cops nearby = rnearby stdRuleset ar = fromMaybe (error $ "" `showFailure` aid) (EM.lookup aid actorAspect) actorMaxSk = IA.aSkills ar alterSkill = EM.findWithDefault 0 AbAlter actorMaxSk lvl@Level{lxsize, lysize} <- getLevel $ blid b let stepAccesible :: AndPath -> Bool stepAccesible AndPath{pathList=q : _} = -- Effectively, only @alterMinWalk@ is checked, because real altering -- is not done via target path, but action after end of path. alterSkill >= fromEnum (lalter PointArray.! q) stepAccesible _ = False mtgtMPath <- getsClient $ EM.lookup aid . stargetD oldTgtUpdatedPath <- case mtgtMPath of Just TgtAndPath{tapTgt,tapPath=NoPath} -> -- This case is especially for TEnemyPos that would be lost otherwise. -- This is also triggered by @UpdLeadFaction@. Just <$> createPath aid tapTgt Just tap@TgtAndPath{..} -> do mvalidPos <- getsState $ aidTgtToPos aid (blid b) tapTgt if | isNothing mvalidPos -> return Nothing -- wrong level | bpos b == pathGoal tapPath -> return mtgtMPath -- goal reached; stay there picking up items | otherwise -> return $! case tapPath of AndPath{pathList=q : rest,..} -> case chessDist (bpos b) q of 0 -> -- step along path let newPath = AndPath{ pathList = rest , pathGoal , pathLen = pathLen - 1 } in if stepAccesible newPath then Just tap{tapPath=newPath} else Nothing 1 -> -- no move or a sidestep last turn if stepAccesible tapPath then mtgtMPath else Nothing _ -> Nothing -- veered off the path AndPath{pathList=[],..}-> Nothing -- path to the goal was partial; let's target again NoPath -> error $ "" `showFailure` tap Nothing -> return Nothing -- no target assigned yet fact <- getsState $ (EM.! bfid b) . sfactionD allFoes <- getsState $ foeRegularAssocs (bfid b) (blid b) dungeon <- getsState sdungeon let canMove = EM.findWithDefault 0 AbMove actorMaxSk > 0 || EM.findWithDefault 0 AbDisplace actorMaxSk > 0 -- Needed for now, because AI targets and shoots enemies -- based on the path to them, not LOS to them: || EM.findWithDefault 0 AbProject actorMaxSk > 0 actorMinSk <- getsState $ actorSkills Nothing aid condCanProject <- condCanProjectM (EM.findWithDefault 0 AbProject actorMaxSk) aid condEnoughGear <- condEnoughGearM aid let condCanMelee = actorCanMelee actorAspect aid b condHpTooLow = hpTooLow b ar friends <- getsState $ friendRegularList (bfid b) (blid b) let canEscape = fcanEscape (gplayer fact) canSmell = IA.aSmell ar > 0 meleeNearby | canEscape = nearby `div` 2 | otherwise = nearby rangedNearby = 2 * meleeNearby -- Don't melee-target nonmoving actors, unless they attack ours, -- because nonmoving can't be lured nor ambushed nor can't chase. -- This is especially important for fences, tower defense actors, etc. -- If content gives nonmoving actor loot, this becomes problematic. targetableMelee aidE body = do actorMaxSkE <- maxActorSkillsClient aidE let attacksFriends = any (adjacent (bpos body) . bpos) friends -- 3 is -- 1 from condSupport1 -- + 2 from foe being 2 away from friend before he closed in -- + 1 for as a margin for ambush, given than actors exploring -- can't physically keep adjacent all the time n | IA.aAggression ar >= 2 = rangedNearby -- boss never waits | condInMelee = if attacksFriends then 4 else 0 | otherwise = meleeNearby nonmoving = EM.findWithDefault 0 AbMove actorMaxSkE <= 0 return {-keep lazy-} $ case chessDist (bpos body) (bpos b) of 1 -> True -- if adjacent, target even if can't melee, to flee cd -> condCanMelee && cd <= n && (not nonmoving || attacksFriends) -- Even when missiles run out, the non-moving foe will still be -- targeted, which is fine, since he is weakened by ranged, so should be -- meleed ASAP, even if without friends. targetableRanged body = (not condInMelee || IA.aAggression ar >= 2) -- boss fires at will && chessDist (bpos body) (bpos b) < rangedNearby && condCanProject targetableEnemy (aidE, body) = do tMelee <- targetableMelee aidE body return $! targetableRanged body || tMelee nearbyFoes <- filterM targetableEnemy allFoes isStairPos <- getsState $ \s lid p -> isStair lid p s discoBenefit <- getsClient sdiscoBenefit fleeD <- getsClient sfleeD s <- getState getKind <- getsState $ flip getIidKind let desirableBagFloor bag = any (\iid -> let Benefit{benPickup} = discoBenefit EM.! iid in desirableItem canEscape benPickup (getKind iid)) $ EM.keys bag desirableFloor (_, (_, bag)) = desirableBagFloor bag focused = gearSpeed ar < speedWalk || condHpTooLow couldMoveLastTurn = let actorSk = if mleader == Just aid then actorMaxSk else actorMinSk in EM.findWithDefault 0 AbMove actorSk > 0 isStuck = waitedLastTurn b && couldMoveLastTurn slackTactic = ftactic (gplayer fact) `elem` [TMeleeAndRanged, TMeleeAdjacent, TBlock, TRoam, TPatrol] setPath :: Target -> m (Maybe TgtAndPath) setPath tgt = do let take7 tap@TgtAndPath{tapTgt=TEnemy{}} = tap -- @TEnemy@ needed for projecting, even by roaming actors take7 tap@TgtAndPath{tapTgt,tapPath=AndPath{..}} = if slackTactic then -- Best path only followed 7 moves; then straight on. Cheaper. let path7 = take 7 pathList vtgt | bpos b == pathGoal = tapTgt -- goal reached | otherwise = TVector $ towards (bpos b) pathGoal in TgtAndPath{tapTgt=vtgt, tapPath=AndPath{pathList=path7, ..}} else tap take7 tap = tap tgtpath <- createPath aid tgt return $ Just $ take7 tgtpath pickNewTarget :: m (Maybe TgtAndPath) pickNewTarget = do cfoes <- closestFoes nearbyFoes aid case cfoes of (_, (aid2, _)) : _ -> setPath $ TEnemy aid2 False [] | condInMelee -> return Nothing -- don't slow down fighters -- this looks a bit strange, because teammates stop in their tracks -- all around the map (unless very close to the combatant), -- but the intuition is, not being able to help immediately, -- and not being too friendly to each other, they just wait and see -- and also shout to the teammate to flee and lure foes into ambush [] -> do -- Tracking enemies is more important than exploring, -- and smelling actors are usually blind, so bad at exploring. smpos <- if canSmell then closestSmell aid else return [] case smpos of [] -> do citemsRaw <- closestItems aid let citems = toFreq "closestItems" $ filter desirableFloor citemsRaw if nullFreq citems then do -- This is mostly lazy and referred to a few times below. ctriggersRaw <- closestTriggers ViaAnything aid let ctriggers = toFreq "closestTriggers" ctriggersRaw if nullFreq ctriggers then 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 pathSource = bpos b tra = trajectoryToPathBounded lxsize lysize pathSource (replicate 7 v) pathList = nub tra pathGoal = last pathList pathLen = length pathList return $ Just $ TgtAndPath { tapTgt = TVector v , tapPath = if pathLen == 0 then NoPath else AndPath{..} } oldpos = fromMaybe originPoint (boldpos b) vOld = bpos b `vectorToFrom` oldpos pNew = shiftBounded lxsize lysize (bpos b) vOld if slackTactic && not isStuck && isUnit vOld && bpos b /= pNew && Tile.isWalkable coTileSpeedup (lvl `at` pNew) -- if initial altering, consider carefully below then vToTgt vOld else do upos <- closestUnknown aid case upos of Nothing -> do modifyClient $ \cli -> cli {sexplored = ES.insert (blid b) (sexplored cli)} explored <- getsClient sexplored let allExplored = ES.size explored == EM.size dungeon if allExplored || nullFreq ctriggers 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 TKnown (blid b) furthest else do (p, (p0, bag)) <- rndToAction $ frequency ctriggers setPath $ TPoint (TEmbed bag p0) (blid b) p else do (p, (p0, bag)) <- rndToAction $ frequency ctriggers setPath $ TPoint (TEmbed bag p0) (blid b) p Just p -> setPath $ TPoint TUnknown (blid b) p else do (p, (p0, bag)) <- rndToAction $ frequency ctriggers setPath $ TPoint (TEmbed bag p0) (blid b) p else do (p, bag) <- rndToAction $ frequency citems setPath $ TPoint (TItem bag) (blid b) p (_, (p, _)) : _ -> setPath $ TPoint TSmell (blid b) p tellOthersNothingHere pos = do let f TgtAndPath{tapTgt} = case tapTgt of TPoint _ lid p -> p /= pos || lid /= blid b _ -> True modifyClient $ \cli -> cli {stargetD = EM.filter f (stargetD cli)} pickNewTarget tileAdj :: (Point -> Bool) -> Point -> Bool tileAdj f p = any f $ vicinityUnsafe p followingWrong permit = permit && (condInMelee -- in melee, stop following || mleader == Just aid) -- a leader, never follow updateTgt :: TgtAndPath -> m (Maybe TgtAndPath) updateTgt TgtAndPath{tapPath=NoPath} = pickNewTarget updateTgt _ | EM.member aid fleeD = pickNewTarget -- forget enemy positions to prevent attacking them again soon updateTgt tap@TgtAndPath{tapPath=AndPath{..},tapTgt} = case tapTgt of TEnemy a permit -> do body <- getsState $ getActorBody a if | (condInMelee -- fight close foes or nobody at all || not focused && not (null nearbyFoes)) -- prefers closer foes && a `notElem` map fst nearbyFoes -- old one not close enough || blid body /= blid b -- wrong level || actorDying body -> -- foe already dying pickNewTarget | followingWrong permit -> pickNewTarget | bpos body == pathGoal -> return $ Just tap -- 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. | otherwise -> do -- If there are no unwalkable tiles on the path to enemy, -- he gets target @TEnemy@ and then, even if such tiles emerge, -- the target updated by his moves remains @TEnemy@. -- Conversely, he is stuck with @TKnown@ if initial target had -- unwalkable tiles, for as long as they remain. Harmless quirk. mpath <- getCachePath aid $ bpos body case mpath of NoPath -> pickNewTarget -- enemy became unreachable AndPath{pathLen=0} -> pickNewTarget -- he is his own enemy AndPath{} -> return $ Just tap{tapPath=mpath} -- In this case, need to retarget, to focus on foes that melee ours -- and not, e.g., on remembered foes or items. _ | condInMelee -> pickNewTarget TPoint _ lid _ | lid /= blid b -> pickNewTarget -- wrong level TPoint tgoal lid pos -> case tgoal of _ | not $ null nearbyFoes -> pickNewTarget -- prefer close foes to anything else TEnemyPos _ permit -- chase last position even if foe hides | bpos b == pos -> tellOthersNothingHere pos | followingWrong permit -> pickNewTarget | otherwise -> return $ Just tap -- Below we check the target could not be picked again in -- pickNewTarget (e.g., an item got picked up by our teammate) -- and only in this case it is invalidated. -- This ensures targets are eventually reached (unless a foe -- shows up) and not changed all the time mid-route -- to equally interesting, but perhaps a bit closer targets, -- most probably already targeted by other actors. TEmbed bag p -> assert (adjacent pos p) $ do -- First, stairs and embedded items from @closestTriggers@. -- We don't check skills, because they normally don't change -- or we can put some equipment back and recover them. -- We don't determine if the stairs or embed are interesting -- (this changes with time), but allow the actor -- to reach them and then retarget. The two things we check -- is whether the embedded bag is still there, or used up -- and whether we happen to be already adjacent to @p@, -- even though not necessarily at @pos@. bag2 <- getsState $ getEmbedBag lid p -- not @pos@ if | bag /= bag2 -> pickNewTarget -- others will notice soon enough | adjacent (bpos b) p -> -- regardless if at @pos@ or not setPath $ TPoint TAny lid (bpos b) -- stay there one turn (high chance to become leader) -- to enable triggering; if trigger fails -- (e.g, changed skills), will retarget next turn (@TAny@) | otherwise -> return $ Just tap TItem bag -> do bag2 <- getsState $ getFloorBag lid pos if | bag /= bag2 -> pickNewTarget -- others will notice soon enough | bpos b == pos -> setPath $ TPoint TAny lid (bpos b) -- stay there one turn (high chance to become leader) -- to enable pickup; if pickup fails, will retarget | otherwise -> return $ Just tap TSmell -> let lvl2 = sdungeon s EM.! lid in if not canSmell || let sml = EM.findWithDefault timeZero pos (lsmell lvl2) in sml <= ltime lvl2 then pickNewTarget -- others will notice soon enough else return $ Just tap TUnknown -> let lvl2 = sdungeon s EM.! lid t = lvl2 `at` pos in if lexpl lvl2 <= lseen lvl2 || not (isUknownSpace t) || condEnoughGear && tileAdj (isStairPos lid) pos -- the unknown may be on the other side of the level -- and getting there only to explore 1 tile and get back -- looks silly then pickNewTarget -- others will notice soon enough else return $ Just tap TKnown -> do -- e.g., staircase or first unknown tile of an area explored <- getsClient sexplored let allExplored = ES.size explored == EM.size dungeon lvl2 = sdungeon s EM.! lid if bpos b == pos || isStuck || alterSkill < fromEnum (lalter PointArray.! pos) -- tile was searched or altered or skill lowered || Tile.isWalkable coTileSpeedup (lvl2 `at` pos) && not allExplored -- not patrolling explored dungeon -- tile is no longer unwalkable, so was explored -- so time to recalculate target then pickNewTarget -- others unconcerned else return $ Just tap TAny -> pickNewTarget -- reset elsewhere or carried over from UI TVector{} -> if pathLen > 1 then return $ Just tap else pickNewTarget if canMove then case oldTgtUpdatedPath of Nothing -> pickNewTarget Just tap -> updateTgt tap else return $ Just $ TgtAndPath (TEnemy aid True) NoPath LambdaHack-0.8.3.0/Game/LambdaHack/Client/AI/HandleAbilityM.hs0000644000000000000000000013544113315545734021550 0ustar0000000000000000-- | AI procedure for picking the best action for an actor. module Game.LambdaHack.Client.AI.HandleAbilityM ( pickAction #ifdef EXPOSE_INTERNAL -- * Internal operations , actionStrategy , waitBlockNow, pickup, equipItems, toShare, yieldUnneeded, unEquipItems , groupByEqpSlot, bestByEqpSlot, harmful, meleeBlocker, meleeAny , trigger, projectItem, ApplyItemGroup, applyItem, flee , displaceFoe, displaceBlocker, displaceTgt , chase, moveTowards, moveOrRunAid #endif ) where import Prelude () import Game.LambdaHack.Common.Prelude import Data.Either import qualified Data.EnumMap.Lazy as LEM import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES import Data.Function import Data.Ord import Data.Ratio import Game.LambdaHack.Client.AI.ConditionM import Game.LambdaHack.Client.AI.Strategy import Game.LambdaHack.Client.Bfs import Game.LambdaHack.Client.BfsM import Game.LambdaHack.Client.CommonM import Game.LambdaHack.Client.MonadClient import Game.LambdaHack.Client.Request import Game.LambdaHack.Client.State import Game.LambdaHack.Common.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 qualified Game.LambdaHack.Common.ItemAspect as IA import Game.LambdaHack.Common.Kind import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.MonadStateRead import Game.LambdaHack.Common.Point import qualified Game.LambdaHack.Common.PointArray as PointArray import Game.LambdaHack.Common.Random import Game.LambdaHack.Common.ReqFailure import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile import Game.LambdaHack.Common.Time import Game.LambdaHack.Common.Vector import qualified Game.LambdaHack.Content.ItemKind as IK import Game.LambdaHack.Content.ModeKind -- | Pick the most desirable AI ation for the actor. pickAction :: MonadClient m => ActorId -> Bool -> m RequestTimed {-# INLINE pickAction #-} pickAction aid retry = do side <- getsClient sside body <- getsState $ getActorBody aid let !_A = assert (bfid body == side `blame` "AI tries to move enemy actor" `swith` (aid, bfid body, side)) () let !_A = assert (isNothing (btrajectory body) && not (bproj body) `blame` "AI gets to manually move its trajectory actors" `swith` (aid, bfid body, side)) () -- Reset fleeing flag. May then be set in @flee@. modifyClient $ \cli -> cli {sfleeD = EM.delete aid (sfleeD cli)} stratAction <- actionStrategy aid retry let bestAction = bestVariant stratAction !_A = assert (not (nullFreq bestAction) -- equiv to nullStrategy `blame` "no AI action for actor" `swith` (stratAction, aid, body)) () -- Run the AI: chose an action from those given by the AI strategy. rndToAction $ frequency bestAction -- AI strategy based on actor's sight, smell, etc. -- Never empty. actionStrategy :: forall m. MonadClient m => ActorId -> Bool -> m (Strategy RequestTimed) {-# INLINE actionStrategy #-} actionStrategy aid retry = do body <- getsState $ getActorBody aid scondInMelee <- getsClient scondInMelee let condInMelee = scondInMelee LEM.! blid body condAimEnemyPresent <- condAimEnemyPresentM aid condAimEnemyRemembered <- condAimEnemyRememberedM aid condAnyFoeAdj <- condAnyFoeAdjM aid threatDistL <- getsState $ meleeThreatDistList aid (fleeL, badVic) <- fleeList aid condSupport1 <- condSupport 1 aid condSupport3 <- condSupport 3 aid condSolo <- condSoloM aid -- solo fighters aggresive canDeAmbientL <- getsState $ canDeAmbientList body actorSk <- currentSkillsClient aid condCanProject <- condCanProjectM (EM.findWithDefault 0 AbProject actorSk) aid condAdjTriggerable <- condAdjTriggerableM aid condBlocksFriends <- condBlocksFriendsM aid condNoEqpWeapon <- condNoEqpWeaponM aid condEnoughGear <- condEnoughGearM aid condFloorWeapon <- condFloorWeaponM aid condDesirableFloorItem <- condDesirableFloorItemM aid condTgtNonmoving <- condTgtNonmovingM aid explored <- getsClient sexplored actorAspect <- getsState sactorAspect let ar = actorAspect EM.! aid lidExplored = ES.member (blid body) explored panicFleeL = fleeL ++ badVic condHpTooLow = hpTooLow body ar condNotCalmEnough = not (calmEnough body ar) speed1_5 = speedScale (3%2) (gearSpeed ar) condCanMelee = actorCanMelee actorAspect aid body condMeleeBad = not ((condSolo || condSupport1) && condCanMelee) condThreat n = not $ null $ takeWhile ((<= n) . fst) threatDistL threatAdj = takeWhile ((== 1) . fst) threatDistL condManyThreatAdj = length threatAdj >= 2 condFastThreatAdj = any (\(_, (aid2, _)) -> let ar2 = actorAspect EM.! aid2 in gearSpeed ar2 > speed1_5) threatAdj heavilyDistressed = -- actor hit by a proj or similarly distressed deltaSerious (bcalmDelta body) actorShines = IA.aShine ar > 0 aCanDeLightL | actorShines = [] | otherwise = canDeAmbientL aCanDeLight = not $ null aCanDeLightL canFleeFromLight = not $ null $ aCanDeLightL `intersect` map snd fleeL actorMaxSk = IA.aSkills ar abInMaxSkill ab = EM.findWithDefault 0 ab actorMaxSk > 0 runSkills = [AbMove, AbDisplace, AbAlter] stratToFreq :: Int -> m (Strategy RequestTimed) -> m (Frequency RequestTimed) stratToFreq scale mstrat = do st <- mstrat return $! if scale == 0 then mzero else scaleFreq scale $ bestVariant st -- Order matters within the list, because it's summed with .| after -- filtering. Also, the results of prefix, distant and suffix -- are summed with .| at the end. prefix, suffix :: [([Ability], m (Strategy RequestTimed), Bool)] prefix = [ ( [AbApply] , applyItem aid ApplyFirstAid , not condAnyFoeAdj && condHpTooLow) , ( [AbAlter] , trigger aid ViaStairs -- explore next or flee via stairs, even if to wrong level; -- in the latter case, may return via different stairs later on , condAdjTriggerable && not condAimEnemyPresent && ((condNotCalmEnough || condHpTooLow) -- flee && condMeleeBad && condThreat 1 || (lidExplored || condEnoughGear) -- explore && not condDesirableFloorItem) ) , ( [AbDisplace] , displaceFoe aid -- only swap with an enemy to expose him , condAnyFoeAdj && condBlocksFriends) -- later checks foe eligible , ( [AbMoveItem] , pickup aid True , condNoEqpWeapon -- we assume organ weapons usually inferior && condFloorWeapon && not condHpTooLow && abInMaxSkill AbMelee ) , ( [AbAlter] , trigger aid ViaEscape , condAdjTriggerable && not condAimEnemyPresent && not condDesirableFloorItem ) -- collect the last loot , ( runSkills , flee aid fleeL , -- Flee either from melee, if our melee is bad and enemy close -- or from missiles, if hit and enemies are only far away, -- can fling at us and we can't well fling at them. not condFastThreatAdj && if | condThreat 1 -> not condCanMelee || condManyThreatAdj && not condSupport1 && not condSolo | not condInMelee && (condThreat 2 || condThreat 5 && canFleeFromLight) -> -- Don't keep fleeing if just hit, because too close -- to enemy to get out of his range, most likely, -- and so melee him instead, unless can't melee at all. not condCanMelee || not condSupport3 && not condSolo && not heavilyDistressed | condThreat 5 -> -- Too far to flee from melee, too close from ranged, -- not in ambient, so no point fleeing into dark; advance. False | otherwise -> -- If I'm hit, they are still in range to fling at me, -- even if I can't see them. And probably far away. -- Too far to close in for melee; can't shoot; flee from -- ranged attack and prepare ambush for later on. not condInMelee && heavilyDistressed && (not condCanProject || canFleeFromLight) ) , ( [AbMelee] , meleeBlocker aid -- only melee blocker , condAnyFoeAdj -- if foes, don't displace, otherwise friends: || not (abInMaxSkill AbDisplace) -- displace friends, if possible && condAimEnemyPresent ) -- excited -- So animals block each other until hero comes and then -- the stronger makes a show for him and kills the weaker. , ( [AbAlter] , trigger aid ViaNothing , not condInMelee -- don't incur overhead && condAdjTriggerable && not condAimEnemyPresent ) , ( [AbDisplace] -- prevents some looping movement , displaceBlocker aid retry -- fires up only when path blocked , retry || not condDesirableFloorItem ) , ( [AbMelee] , meleeAny aid , condAnyFoeAdj ) -- won't flee nor displace, so let it melee , ( runSkills , flee aid panicFleeL -- ultimate panic mode, displaces foes , condAnyFoeAdj ) ] -- Order doesn't matter, scaling does. -- These are flattened (taking only the best variant) and then summed, -- so if any of these can fire, it will fire. If none, @suffix@ is tried. -- Only the best variant of @chase@ is taken, but it's almost always -- good, and if not, the @chase@ in @suffix@ may fix that. distant :: [([Ability], m (Frequency RequestTimed), Bool)] distant = [ ( [AbMoveItem] , stratToFreq (if condInMelee then 2 else 20000) $ yieldUnneeded aid -- 20000 to unequip ASAP, unless is thrown , True ) , ( [AbMoveItem] , stratToFreq 1 $ equipItems aid -- doesn't take long, very useful if safe , not (condInMelee || condDesirableFloorItem || condNotCalmEnough || heavilyDistressed) ) , ( [AbProject] , stratToFreq (if condTgtNonmoving then 20 else 3) -- not too common, to leave missiles for pre-melee dance $ projectItem aid -- equivalent of @condCanProject@ called inside , condAimEnemyPresent && not condInMelee ) , ( [AbApply] , stratToFreq 1 $ applyItem aid ApplyAll -- use any potion or scroll , condAimEnemyPresent || condThreat 9 ) -- can affect enemies , ( runSkills , stratToFreq (if | condInMelee -> 400 -- friends pummeled by target, go to help | not condAimEnemyPresent -> 2 -- if enemy only remembered, investigate anyway | otherwise -> 20) $ chase aid (not condInMelee && (condThreat 12 || heavilyDistressed) && aCanDeLight) retry , condCanMelee && (if condInMelee then condAimEnemyPresent else (condAimEnemyPresent || condAimEnemyRemembered) && (not (condThreat 2) || heavilyDistressed -- if under fire, do something! || not condMeleeBad) -- this results in animals in corridor never attacking -- (unless distressed by, e.g., being hit by missiles), -- because they can't swarm opponent, which is logical, -- and in rooms they do attack, so not too boring; -- two aliens attack always, because more aggressive && not condDesirableFloorItem) ) ] -- Order matters again. suffix = [ ( [AbMoveItem] , pickup aid False -- e.g., to give to other party members , not condInMelee ) , ( [AbMoveItem] , unEquipItems aid -- late, because these items not bad , not condInMelee ) , ( runSkills , chase aid (not condInMelee && heavilyDistressed && aCanDeLight) retry , if condInMelee then condCanMelee && condAimEnemyPresent else not (condThreat 2) || not condMeleeBad ) ] fallback = [ ( [AbWait] , waitBlockNow -- Wait until friends sidestep; ensures strategy is never empty. , True ) ] -- Check current, not maximal skills, since this can be a leader as well -- as non-leader action. let abInSkill ab = EM.findWithDefault 0 ab actorSk > 0 checkAction :: ([Ability], m a, Bool) -> Bool checkAction (abts, _, cond) = any 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 waitBlockNow :: MonadClient m => m (Strategy RequestTimed) waitBlockNow = return $! returN "wait" ReqWait pickup :: MonadClient m => ActorId -> Bool -> m (Strategy RequestTimed) pickup aid onlyWeapon = do benItemL <- benGroundItems aid b <- getsState $ getActorBody aid -- This calmE is outdated when one of the items increases max Calm -- (e.g., in pickup, which handles many items at once), but this is OK, -- the server accepts item movement based on calm at the start, not end -- or in the middle. -- The calmE is inaccurate also if an item not IDed, but that's intended -- and the server will ignore and warn (and content may avoid that, -- e.g., making all rings identified) ar <- getsState $ getActorAspect aid let calmE = calmEnough b ar isWeapon (_, _, _, itemFull, _) = IK.isMelee $ itemKind itemFull filterWeapon | onlyWeapon = filter isWeapon | otherwise = id prepareOne (oldN, l4) (Benefit{benInEqp}, _, iid, ItemFull{itemKind}, (itemK, _)) = let prep newN toCStore = (newN, (iid, itemK, CGround, toCStore) : l4) n = oldN + itemK in if | calmE && IK.goesIntoSha itemKind && not onlyWeapon -> prep oldN CSha | benInEqp && eqpOverfull b n -> if onlyWeapon then (oldN, l4) else prep oldN (if calmE then CSha else CInv) | benInEqp -> prep n CEqp | not onlyWeapon -> prep oldN CInv | otherwise -> (oldN, l4) (_, prepared) = foldl' prepareOne (0, []) $ filterWeapon benItemL return $! if null prepared then reject else returN "pickup" $ ReqMoveItems prepared -- This only concerns items that can be equipped, that is with a slot -- and with @inEqp@ (which implies @goesIntoEqp@). -- Such items are moved between any stores, as needed. In this case, -- from inv or sha to eqp. equipItems :: MonadClient m => ActorId -> m (Strategy RequestTimed) equipItems aid = do body <- getsState $ getActorBody aid ar <- getsState $ getActorAspect aid let calmE = calmEnough body ar eqpAssocs <- getsState $ kitAssocs aid [CEqp] invAssocs <- getsState $ kitAssocs aid [CInv] shaAssocs <- getsState $ kitAssocs aid [CSha] condShineWouldBetray <- condShineWouldBetrayM aid condAimEnemyPresent <- condAimEnemyPresentM aid discoBenefit <- getsClient sdiscoBenefit let improve :: CStore -> (Int, [(ItemId, Int, CStore, CStore)]) -> ( IA.EqpSlot , ( [(Int, (ItemId, ItemFullKit))] , [(Int, (ItemId, ItemFullKit))] ) ) -> (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, _) : _) | vInv > vEqp && not (eqpOverfull body n) -- Only add random minor boosts if one slot remains free -- for major boosts, to avoid wield/unwield loops. -- All slots may be taken only via adding major boosts. || not (toShare slot) && not (eqpOverfull body (n + 1)) -> (n, (iidInv, 1, fromCStore, CEqp) : l4) _ -> (oldN, l4) heavilyDistressed = -- Actor hit by a projectile or similarly distressed. deltaSerious (bcalmDelta body) -- We filter out unneeded items. In particular, we ignore them in eqp -- when comparing to items we may want to equip, so that the unneeded -- but powerful items don't fool us. -- In any case, the unneeded items should be removed from equip -- in @yieldUnneeded@ earlier or soon after this check. -- In other stores we need to filter, for otherwise we'd have -- a loop of equip/yield. filterNeeded (_, (itemFull, _)) = not $ hinders condShineWouldBetray condAimEnemyPresent heavilyDistressed (not calmE) ar itemFull bestThree = bestByEqpSlot discoBenefit (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 :: IA.EqpSlot -> Bool toShare IA.EqpSlotMiscBonus = False toShare IA.EqpSlotMiscAbility = False toShare _ = True yieldUnneeded :: MonadClient m => ActorId -> m (Strategy RequestTimed) yieldUnneeded aid = do body <- getsState $ getActorBody aid ar <- getsState $ getActorAspect aid let calmE = calmEnough body ar eqpAssocs <- getsState $ kitAssocs aid [CEqp] condShineWouldBetray <- condShineWouldBetrayM aid condAimEnemyPresent <- condAimEnemyPresentM aid discoBenefit <- getsClient sdiscoBenefit -- Here and in @unEquipItems@ AI may hide from the human player, -- in shared stash, the Ring of Speed And Bleeding, -- which is a bit harsh, but fair. However any subsequent such -- rings will not be picked up at all, so the human player -- doesn't lose much fun. Additionally, if AI learns alchemy later on, -- they can repair the ring, wield it, drop at death and it's -- in play again. let heavilyDistressed = -- Actor hit by a projectile or similarly distressed. deltaSerious (bcalmDelta body) csha = if calmE then CSha else CInv yieldSingleUnneeded (iidEqp, (itemEqp, (itemK, _))) = if | harmful discoBenefit iidEqp -> [(iidEqp, itemK, CEqp, CInv)] -- harmful not shared | hinders condShineWouldBetray condAimEnemyPresent heavilyDistressed (not calmE) ar itemEqp -> [(iidEqp, itemK, CEqp, csha)] | otherwise -> [] yieldAllUnneeded = concatMap yieldSingleUnneeded eqpAssocs return $! if null yieldAllUnneeded then reject else returN "yieldUnneeded" $ ReqMoveItems yieldAllUnneeded -- This only concerns items that can be equipped, that is with a slot -- and with @inEqp@ (which implies @goesIntoEqp@). -- Such items are moved between any stores, as needed. In this case, -- from inv or eqp to sha. unEquipItems :: MonadClient m => ActorId -> m (Strategy RequestTimed) unEquipItems aid = do body <- getsState $ getActorBody aid ar <- getsState $ getActorAspect aid let calmE = calmEnough body ar eqpAssocs <- getsState $ kitAssocs aid [CEqp] invAssocs <- getsState $ kitAssocs aid [CInv] shaAssocs <- getsState $ kitAssocs aid [CSha] condShineWouldBetray <- condShineWouldBetrayM aid condAimEnemyPresent <- condAimEnemyPresentM aid discoBenefit <- getsClient sdiscoBenefit let improve :: CStore -> ( IA.EqpSlot , ( [(Int, (ItemId, ItemFullKit))] , [(Int, (ItemId, ItemFullKit))] ) ) -> [(ItemId, Int, CStore, CStore)] improve fromCStore (slot, (bestSha, bestEOrI)) = case bestEOrI of _ | not (toShare slot) && fromCStore == CEqp && not (eqpOverfull body 1) -> -- keep minor boosts up to M-1 [] ((vEOrI, (iidEOrI, bei)) : _) | (toShare slot || fromCStore == CInv) && getK bei > 1 && betterThanSha vEOrI bestSha -> -- To share the best items with others, if they care. [(iidEOrI, getK bei - 1, fromCStore, CSha)] (_ : (vEOrI, (iidEOrI, bei)) : _) | (toShare slot || fromCStore == CInv) && betterThanSha vEOrI bestSha -> -- To share the second best items with others, if they care. [(iidEOrI, getK bei, fromCStore, CSha)] ((vEOrI, (_, _)) : _) | fromCStore == CEqp && eqpOverfull body 1 && worseThanSha vEOrI bestSha -> -- To make place in eqp for an item better than any ours. -- Even a minor boost is removed only if sha has a better one. [(fst $ snd $ last bestEOrI, 1, fromCStore, CSha)] _ -> [] getK (_, (itemK, _)) = itemK betterThanSha _ [] = True betterThanSha vEOrI ((vSha, _) : _) = vEOrI > vSha worseThanSha _ [] = False worseThanSha vEOrI ((vSha, _) : _) = vEOrI < vSha heavilyDistressed = -- Actor hit by a projectile or similarly distressed. deltaSerious (bcalmDelta body) -- Here we don't need to filter out items that hinder (except in sha) -- because they are moved to sha and will be equipped by another actor -- at another time, where hindering will be completely different. -- If they hinder and we unequip them, all the better. -- We filter sha to consider only eligible items in @worseThanSha@. filterNeeded (_, (itemFull, _)) = not $ hinders condShineWouldBetray condAimEnemyPresent heavilyDistressed (not calmE) ar itemFull bestThree = bestByEqpSlot discoBenefit 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, ItemFullKit)] -> EM.EnumMap IA.EqpSlot [(ItemId, ItemFullKit)] groupByEqpSlot is = let f (iid, itemFullKit) = case IK.getEqpSlot $ itemKind $ fst itemFullKit of Nothing -> Nothing Just es -> Just (es, [(iid, itemFullKit)]) withES = mapMaybe f is in EM.fromListWith (++) withES bestByEqpSlot :: DiscoveryBenefit -> [(ItemId, ItemFullKit)] -> [(ItemId, ItemFullKit)] -> [(ItemId, ItemFullKit)] -> [(IA.EqpSlot , ( [(Int, (ItemId, ItemFullKit))] , [(Int, (ItemId, ItemFullKit))] , [(Int, (ItemId, ItemFullKit))] ) )] bestByEqpSlot discoBenefit eqpAssocs invAssocs shaAssocs = let eqpMap = EM.map (\g -> (g, [], [])) $ groupByEqpSlot eqpAssocs invMap = EM.map (\g -> ([], g, [])) $ groupByEqpSlot invAssocs shaMap = EM.map (\g -> ([], [], g)) $ groupByEqpSlot shaAssocs appendThree (g1, g2, g3) (h1, h2, h3) = (g1 ++ h1, g2 ++ h2, g3 ++ h3) eqpInvShaMap = EM.unionsWith appendThree [eqpMap, invMap, shaMap] bestSingle = strongestSlot discoBenefit bestThree eqpSlot (g1, g2, g3) = (bestSingle eqpSlot g1, bestSingle eqpSlot g2, bestSingle eqpSlot g3) in EM.assocs $ EM.mapWithKey bestThree eqpInvShaMap harmful :: DiscoveryBenefit -> ItemId -> Bool harmful discoBenefit iid = -- Items that are known, perhaps recently discovered, and it's now revealed -- they should not be kept in equipment, should be unequipped -- (either they are harmful or they waste eqp space). not $ benInEqp $ discoBenefit EM.! iid -- Everybody melees in a pinch, even though some prefer ranged attacks. meleeBlocker :: MonadClient m => ActorId -> m (Strategy RequestTimed) meleeBlocker aid = do b <- getsState $ getActorBody aid actorAspect <- getsState sactorAspect let ar = actorAspect EM.! aid fact <- getsState $ (EM.! bfid b) . sfactionD actorSk <- currentSkillsClient aid mtgtMPath <- getsClient $ EM.lookup aid . stargetD case mtgtMPath of Just TgtAndPath{ tapTgt=TEnemy{} , tapPath=AndPath{pathList=q : _, pathGoal} } | q == pathGoal -> return reject -- not a real blocker, but goal enemy Just TgtAndPath{tapPath=AndPath{pathList=q : _, pathGoal}} -> do -- We prefer the goal position, so that we can kill the foe and enter it, -- but we accept any @q@ as well. let maim | adjacent (bpos b) pathGoal = Just pathGoal | adjacent (bpos b) q = Just q | otherwise = Nothing -- MeleeDistant lBlocker <- case maim of Nothing -> return [] Just aim -> getsState $ posToAssocs aim (blid b) case lBlocker of (aid2, body2) : _ -> do let ar2 = actorAspect EM.! aid2 -- No problem if there are many projectiles at the spot. We just -- attack the first one. if | actorDying body2 || bproj body2 -- displacing saves a move, so don't melee && EM.findWithDefault 0 AbDisplace actorSk > 0 -> return reject | isFoe (bfid b) fact (bfid body2) -- at war with us, so hit, not displace || isFriend (bfid b) fact (bfid body2) -- don't start a war && EM.findWithDefault 0 AbDisplace actorSk <= 0 -- can't disp && EM.findWithDefault 0 AbMove actorSk > 0 -- blocked move && 3 * bhp body2 < bhp b -- only get rid of weak friends && gearSpeed ar2 <= gearSpeed ar -> do mel <- maybeToList <$> pickWeaponClient aid aid2 return $! liftFrequency $ uniformFreq "melee in the way" mel | otherwise -> return reject [] -> return reject _ -> return reject -- probably no path to the enemy, if any -- Everybody melees in a pinch, skills and weapons allowing, -- even though some prefer ranged attacks. meleeAny :: MonadClient m => ActorId -> m (Strategy RequestTimed) meleeAny aid = do b <- getsState $ getActorBody aid fact <- getsState $ (EM.! bfid b) . sfactionD adjacentAssocs <- getsState $ actorAdjacentAssocs b let foe (_, b2) = not (bproj b2) && isFoe (bfid b) fact (bfid b2) && bhp b2 > 0 adjFoes = filter foe adjacentAssocs btarget <- getsClient $ getTarget aid mtarget <- case btarget of Just (TEnemy aid2 _) -> do b2 <- getsState $ getActorBody aid2 return $! if adjacent (bpos b2) (bpos b) && foe (aid2, b2) then Just (aid2, b2) else Nothing _ -> return Nothing let adjTargets = maybe adjFoes return mtarget mels <- mapM (pickWeaponClient aid . fst) adjTargets let freq = uniformFreq "melee adjacent" $ catMaybes mels return $! liftFrequency freq -- The level the actor is on is either explored or the actor already -- has a weapon equipped, so no need to explore further, he tries to find -- enemies on other levels. -- We don't verify any embedded item is targeted by the actor, but at least -- the actor doesn't target a visible enemy at this point. trigger :: MonadClient m => ActorId -> FleeViaStairsOrEscape -> m (Strategy RequestTimed) trigger aid fleeVia = do b <- getsState $ getActorBody aid lvl <- getLevel (blid b) let f pos = case EM.lookup pos $ lembed lvl of Nothing -> Nothing Just bag -> Just (pos, bag) pbags = mapMaybe f $ vicinityUnsafe (bpos b) efeat <- embedBenefit fleeVia aid pbags return $! liftFrequency $ toFreq "trigger" [ (ceiling benefit, ReqAlter pos) | (benefit, (pos, _)) <- efeat ] projectItem :: MonadClient m => ActorId -> m (Strategy RequestTimed) projectItem aid = do btarget <- getsClient $ getTarget aid b <- getsState $ getActorBody aid mfpos <- case btarget of Nothing -> return Nothing Just target -> getsState $ aidTgtToPos aid (blid b) target seps <- getsClient seps case (btarget, mfpos) of (_, Just fpos) | adjacent (bpos b) fpos -> return reject (Just TEnemy{}, Just fpos) -> do mnewEps <- makeLine False b fpos seps case mnewEps of Just newEps -> do actorSk <- currentSkillsClient aid let skill = EM.findWithDefault 0 AbProject actorSk -- ProjectAimOnself, ProjectBlockActor, ProjectBlockTerrain -- and no actors or obstacles along the path. benList <- condProjectListM skill aid localTime <- getsState $ getLocalTime (blid b) let coeff CGround = 2 -- pickup turn saved coeff COrgan = error $ "" `showFailure` benList coeff CEqp = 100000 -- must hinder currently coeff CInv = 1 coeff CSha = 1 fRanged (Benefit{benFling}, cstore, iid, itemFull, kit) = -- We assume if the item has a timeout, most effects are under -- Recharging, so no point projecting if not recharged. -- This changes in time, so recharging is not included -- in @condProjectListM@, but checked here, just before fling. let recharged = hasCharge localTime itemFull kit trange = IK.totalRange $ itemKind itemFull bestRange = chessDist (bpos b) fpos + 2 -- margin for fleeing rangeMult = -- penalize wasted or unsafely low range 10 + max 0 (10 - abs (trange - bestRange)) benR = coeff cstore * benFling in if trange >= chessDist (bpos b) fpos && recharged then Just ( - ceiling (benR * fromIntegral rangeMult / 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) applyItem aid applyGroup = do actorSk <- currentSkillsClient aid b <- getsState $ getActorBody aid condShineWouldBetray <- condShineWouldBetrayM aid condAimEnemyPresent <- condAimEnemyPresentM aid localTime <- getsState $ getLocalTime (blid b) ar <- getsState $ getActorAspect aid let calmE = calmEnough b ar condNotCalmEnough = not calmE heavilyDistressed = -- Actor hit by a projectile or similarly distressed. deltaSerious (bcalmDelta b) skill = EM.findWithDefault 0 AbApply actorSk -- This detects if the value of keeping the item in eqp is in fact < 0. hind = hinders condShineWouldBetray condAimEnemyPresent heavilyDistressed condNotCalmEnough ar permittedActor itemFull kit = either (const False) id $ permittedApply localTime skill calmE itemFull kit -- Both effects tweak items, which is only situationally beneficial -- and not really the best idea while in combat. getTweak IK.PolyItem = True getTweak IK.Identify = True getTweak (IK.OneOf l) = any getTweak l getTweak (IK.Recharging eff) = getTweak eff getTweak (IK.Composite l) = any getTweak l getTweak _ = False q (Benefit{benInEqp}, _, _, itemFull@ItemFull{itemKind}, kit) = let durable = IK.Durable `elem` IK.ifeature itemKind in (not benInEqp -- can't wear, so OK to break || durable -- can wear, but can't break, even better || not (IK.isMelee itemKind) -- anything else expendable && hind itemFull) -- hinders now, so possibly often, so away! && permittedActor itemFull kit && not (any getTweak $ IK.ieffects itemKind) && not (IK.isHumanTrinket itemKind) -- hack for elixir of youth -- Organs are not taken into account, because usually they are either -- melee items, so harmful, or periodic, so charging between activations. -- The case of a weak weapon curing poison is too rare to incur overhead. stores = [CEqp, CInv, CGround] ++ [CSha | calmE] discoBenefit <- getsClient sdiscoBenefit benList <- getsState $ benAvailableItems discoBenefit aid stores getKind <- getsState $ flip getIidKind let (myBadGrps, myGoodGrps) = partitionEithers $ mapMaybe (\iid -> let itemKind = getKind iid in if IK.isTmpCondition itemKind then Just $ if benInEqp (discoBenefit EM.! iid) then Left $ toGroupName $ IK.iname itemKind -- conveniently, @iname@ matches @ifreq@ else Right $ toGroupName $ IK.iname itemKind else Nothing) (EM.keys $ borgan b) coeff CGround = 2 -- pickup turn saved coeff COrgan = error $ "" `showFailure` benList coeff CEqp = 1 coeff CInv = 1 coeff CSha = 1 fTool benAv@(Benefit{benApply}, cstore, iid, ItemFull{itemKind}, _) = let -- Don't include @Ascend@ nor @Teleport@, because maybe no foe near. -- Don't include @OneOf@ because other effects may kill you. getHP (IK.RefillHP p) | p > 0 = True getHP (IK.Recharging eff) = getHP eff getHP (IK.Composite l) = any getHP l getHP _ = False heals = any getHP $ IK.ieffects itemKind dropsGrps = IK.getDropOrgans itemKind dropsBadOrgans = not (null myBadGrps) && toGroupName "condition" `elem` dropsGrps || not (null (dropsGrps `intersect` myBadGrps)) dropsGoodOrgans = not (null myGoodGrps) && toGroupName "condition" `elem` dropsGrps || not (null (dropsGrps `intersect` myGoodGrps)) wastesDrop = null myBadGrps && not (null dropsGrps) durable = IK.Durable `elem` IK.ifeature itemKind situationalBenApply | dropsBadOrgans = benApply + 20 | wastesDrop = benApply - 10 | otherwise = benApply benR = ceiling situationalBenApply * if cstore == CEqp && not durable then 1000 -- must hinder currently else coeff cstore canApply = situationalBenApply > 0 && case applyGroup of ApplyFirstAid -> q benAv && heals ApplyAll -> q benAv && not dropsGoodOrgans && (dropsBadOrgans || not (hpEnough b ar && heals)) in if canApply then Just (benR, ReqApply iid cstore) else Nothing benTool = mapMaybe fTool benList return $! liftFrequency $ toFreq "applyItem" benTool -- If low on health or alone, flee in panic, close to the path to target -- and as far from the attackers, as possible. Usually fleeing from -- foes will lead towards friends, but we don't insist on that. flee :: MonadClient m => ActorId -> [(Int, Point)] -> m (Strategy RequestTimed) flee aid fleeL = do b <- getsState $ getActorBody aid -- Regardless if fleeing accomplished, mark the need. modifyClient $ \cli -> cli {sfleeD = EM.insert aid (bpos b) (sfleeD cli)} let vVic = map (second (`vectorToFrom` bpos b)) fleeL str = liftFrequency $ toFreq "flee" vVic mapStrategyM (moveOrRunAid aid) str -- The result of all these conditions is that AI displaces rarely, -- but it can't be helped as long as the enemy is smart enough to form fronts. displaceFoe :: MonadClient m => ActorId -> m (Strategy RequestTimed) displaceFoe aid = do COps{coTileSpeedup} <- getsState scops b <- getsState $ getActorBody aid lvl <- getLevel $ blid b fact <- getsState $ (EM.! bfid b) . sfactionD friends <- getsState $ friendRegularList (bfid b) (blid b) adjacentAssocs <- getsState $ actorAdjacentAssocs b let foe (_, b2) = not (bproj b2) && isFoe (bfid b) fact (bfid b2) -- DisplaceProjectiles adjFoes = filter foe adjacentAssocs walkable p = -- DisplaceAccess Tile.isWalkable coTileSpeedup (lvl `at` p) notLooping body p = -- avoid displace loops boldpos body /= Just p || waitedLastTurn body nFriends body = length $ filter (adjacent (bpos body) . bpos) friends nFrNew = nFriends b + 1 qualifyActor (aid2, body2) = do actorMaxSk <- maxActorSkillsClient aid2 dEnemy <- getsState $ dispEnemy aid aid2 actorMaxSk -- DisplaceDying, DisplaceBraced, DisplaceImmobile, DisplaceSupported let nFrOld = nFriends body2 return $! if walkable (bpos body2) && dEnemy && nFrOld < nFrNew && notLooping b (bpos body2) then Just (nFrOld * nFrOld, ReqDisplace aid2) else Nothing foes <- mapM qualifyActor adjFoes return $! liftFrequency $ toFreq "displaceFoe" $ catMaybes foes displaceBlocker :: MonadClient m => ActorId -> Bool -> m (Strategy RequestTimed) displaceBlocker aid retry = do b <- getsState $ getActorBody aid mtgtMPath <- getsClient $ EM.lookup aid . stargetD case mtgtMPath of Just TgtAndPath{ tapTgt=TEnemy{} , tapPath=AndPath{pathList=q : _, pathGoal} } | q == pathGoal && not retry -> return reject -- not a real blocker but goal, possibly enemy to melee Just TgtAndPath{tapPath=AndPath{pathList=q : _}} | adjacent (bpos b) q -> -- not veered off target displaceTgt aid q retry _ -> return reject -- goal reached displaceTgt :: MonadClient m => ActorId -> Point -> Bool -> m (Strategy RequestTimed) displaceTgt aid target retry = do COps{coTileSpeedup} <- getsState scops b <- getsState $ getActorBody aid let source = bpos b let !_A = assert (adjacent source target) () lvl <- getLevel $ blid b let walkable p = -- DisplaceAccess Tile.isWalkable coTileSpeedup (lvl `at` p) notLooping body p = -- avoid displace loops boldpos body /= Just p || waitedLastTurn body if walkable target && notLooping b target then do mleader <- getsClient sleader mBlocker <- getsState $ posToAssocs target (blid b) case mBlocker of [] -> return reject [(aid2, b2)] | Just aid2 /= mleader -> do mtgtMPath <- getsClient $ EM.lookup aid2 . stargetD enemyTgt <- condAimEnemyPresentM aid enemyPos <- condAimEnemyRememberedM aid enemyTgt2 <- condAimEnemyPresentM aid2 enemyPos2 <- condAimEnemyRememberedM aid2 case mtgtMPath of Just TgtAndPath{tapPath=AndPath{pathList=q : _}} | q == source -- friend wants to swap || retry -- desperate && not (boldpos b == Just target -- and no displace loop && not (waitedLastTurn b)) || (enemyTgt || enemyPos) && not (enemyTgt2 || enemyPos2) -> -- he doesn't have Enemy target and I have, so push him aside, -- because, for heroes, he will never be a leader, so he can't -- step aside himself return $! returN "displace friend" $ ReqDisplace aid2 Just _ -> return reject Nothing -> do -- an enemy or ally or disoriented friend --- swap tfact <- getsState $ (EM.! bfid b2) . sfactionD actorMaxSk <- maxActorSkillsClient aid2 dEnemy <- getsState $ dispEnemy aid aid2 actorMaxSk -- DisplaceDying, DisplaceBraced, DisplaceImmobile, -- DisplaceSupported if not (isFoe (bfid b2) tfact (bfid b)) || dEnemy then return $! returN "displace other" $ ReqDisplace aid2 else return reject _ -> return reject -- DisplaceProjectiles or trying to displace leader else return reject chase :: MonadClient m => ActorId -> Bool -> Bool -> m (Strategy RequestTimed) chase aid avoidAmbient retry = do COps{coTileSpeedup} <- 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 coTileSpeedup (lvl `at` pos) && Tile.isWalkable coTileSpeedup (lvl `at` pos) -- if solid, will be altered and perhaps darkened str <- case mtgtMPath of Just TgtAndPath{tapPath=AndPath{pathList=q : _, ..}} | pathGoal == bpos body -> return reject -- shortcut and just to be sure | not $ avoidAmbient && isAmbient q -> -- With no leader, the goal is vague, so permit arbitrary detours. moveTowards aid q pathGoal (fleaderMode (gplayer fact) == LeaderNull || retry) _ -> return reject -- goal reached or banned ambient lit tile if avoidAmbient && nullStrategy str then chase aid False retry else mapStrategyM (moveOrRunAid aid) str moveTowards :: MonadClient m => ActorId -> Point -> Point -> Bool -> m (Strategy Vector) moveTowards aid target goal relaxed = do b <- getsState $ getActorBody aid actorSk <- currentSkillsClient aid let source = bpos b 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)) () fact <- getsState $ (EM.! bfid b) . sfactionD salter <- getsClient salter noFriends <- getsState $ \s p -> all (isFoe (bfid b) fact . bfid . snd) (posToAssocs p (blid b) s) let lalter = salter EM.! blid b -- Only actors with AbAlter can search for hidden doors, etc. enterableHere p = alterSkill >= fromEnum (lalter PointArray.! p) if noFriends target && enterableHere target then return $! returN "moveTowards adjacent" $ target `vectorToFrom` source else do let goesBack p = Just p == boldpos b nonincreasing p = chessDist source goal >= chessDist p goal isSensible | relaxed = \p -> noFriends p && enterableHere p | otherwise = \p -> nonincreasing p && not (goesBack p) && noFriends p && enterableHere p sensible = [ ((goesBack p, 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. -- 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 => ActorId -> Vector -> m (Maybe RequestTimed) moveOrRunAid source dir = do COps{coTileSpeedup} <- getsState scops sb <- getsState $ getActorBody source actorSk <- currentSkillsClient source let lid = blid sb lvl <- getLevel lid let walkable = -- DisplaceAccess Tile.isWalkable coTileSpeedup (lvl `at` tpos) notLooping body p = -- avoid displace loops boldpos body /= Just p || waitedLastTurn body spos = bpos sb -- source position tpos = spos `shift` dir -- target position t = lvl `at` tpos -- We start by checking actors at the target position, -- which gives a partial information (actors can be invisible), -- as opposed to accessibility (and items) which are always accurate -- (tiles can't be invisible). tgts <- getsState $ posToAssocs tpos lid case tgts of [(target, b2)] | walkable && EM.findWithDefault 0 AbDisplace actorSk > 0 && notLooping sb tpos -> do -- @target@ can be a foe, as well as a friend. tfact <- getsState $ (EM.! bfid b2) . sfactionD actorMaxSk <- maxActorSkillsClient target dEnemy <- getsState $ dispEnemy source target actorMaxSk -- DisplaceDying, DisplaceBraced, DisplaceImmobile, DisplaceSupported if isFoe (bfid b2) tfact (bfid sb) && not dEnemy then return Nothing else return $ Just $ ReqDisplace target [] | walkable && EM.findWithDefault 0 AbMove actorSk > 0 -> -- Movement requires full access. The potential invisible actor is hit. return $ Just $ ReqMove dir [] | not walkable && EM.findWithDefault 0 AbAlter actorSk >= Tile.alterMinWalk coTileSpeedup t -- AlterUnwalked -- Only possible if items allowed inside unwalkable tiles: && EM.notMember tpos (lfloor lvl) -> -- AlterBlockItem -- Not walkable, but alter skill suffices, so search or alter the tile. -- We assume that unalterable unwalkable tiles are protected -- by high skill req. We don't alter walkable tiles (e.g., close doors). return $ Just $ ReqAlter tpos _ -> return Nothing -- can't displace, move nor alter LambdaHack-0.8.3.0/Game/LambdaHack/Client/AI/PickActorM.hs0000644000000000000000000004153013315545734020711 0ustar0000000000000000-- | Picking the AI actor to move and refreshing leader and non-leader targets. module Game.LambdaHack.Client.AI.PickActorM ( pickActorToMove, setTargetFromTactics ) where import Prelude () import Game.LambdaHack.Common.Prelude import qualified Data.EnumMap.Lazy as LEM import qualified Data.EnumMap.Strict as EM import Data.Ratio import Game.LambdaHack.Client.AI.ConditionM import Game.LambdaHack.Client.AI.PickTargetM import Game.LambdaHack.Client.Bfs import Game.LambdaHack.Client.BfsM import Game.LambdaHack.Client.MonadClient import Game.LambdaHack.Client.State import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.Frequency import qualified Game.LambdaHack.Common.ItemAspect as IA 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 Game.LambdaHack.Common.Time import Game.LambdaHack.Content.ModeKind -- | Pick a new leader from among the actors on the current level. -- Refresh the target of the new leader, even if unchanged. pickActorToMove :: MonadClient m => Maybe ActorId -> m ActorId {-# INLINE pickActorToMove #-} pickActorToMove maidToAvoid = do actorAspect <- getsState sactorAspect mleader <- getsClient sleader let oldAid = fromMaybe (error $ "" `showFailure` maidToAvoid) mleader oldBody <- getsState $ getActorBody oldAid let side = bfid oldBody arena = blid oldBody fact <- getsState $ (EM.! side) . sfactionD -- Find our actors on the current level only. ours <- getsState $ filter (isNothing . btrajectory . snd) . fidActorRegularAssocs side arena let pickOld = do void $ refreshTarget (oldAid, oldBody) return oldAid case ours of _ | -- Keep the leader: faction discourages client leader change on level, -- so will only be changed if waits (maidToAvoid) -- to avoid wasting his higher mobility. -- This is OK for monsters even if in melee, because both having -- a meleeing actor a leader (and higher DPS) and rescuing actor -- a leader (and so faster to get in melee range) is good. -- And we are guaranteed that only the two classes of actors are -- not waiting, with some exceptions (urgent unequip, flee via starts, -- melee-less trying to flee, first aid, etc.). snd (autoDungeonLevel fact) && isNothing maidToAvoid -> pickOld [] -> error $ "" `showFailure` (oldAid, oldBody) [_] -> pickOld -- Keep the leader: he is alone on the level. _ -> 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). let refresh aidBody = do mtgt <- refreshTarget aidBody return (aidBody, mtgt) goodGeneric (_, Nothing) = Nothing goodGeneric (_, Just TgtAndPath{tapPath=NoPath}) = Nothing -- this case means melee-less heroes adjacent to foes, etc. -- will never flee if melee is happening; but this is rare; -- this also ensures even if a lone actor melees and nobody -- can come to rescue, he will become and remain the leader, -- because otherwise an explorer would need to become a leader -- and fighter will be 1 clip slower for the whole fight, -- just for a few turns of exploration in return; -- -- also note that when the fighter then becomes a leader -- he may gain quite a lot of time via @swapTime@, -- and so be able to get a double blow on opponents -- or a safe blow and a withdraw (but only once); this is a mild -- exploit that encourages ambush camping (with a non-leader), -- but it's also a rather fun exploit and a straightforward -- consequence of the game mechanics, so it's OK for now goodGeneric ((aid, b), Just tgt) = case maidToAvoid of Nothing | not (aid == oldAid && waitedLastTurn b) -> -- Not the old leader that was stuck last turn -- because he is likely to be still stuck. Just ((aid, b), tgt) Just aidToAvoid | aid /= aidToAvoid -> -- Not an attempted leader stuck this turn. Just ((aid, b), tgt) _ -> Nothing oursTgtRaw <- mapM refresh ours scondInMelee <- getsClient scondInMelee fleeD <- getsClient sfleeD let oursTgt = mapMaybe goodGeneric oursTgtRaw -- This should be kept in sync with @actionStrategy@. actorVulnerable ((aid, body), _) = do let condInMelee = scondInMelee LEM.! blid body ar = fromMaybe (error $ "" `showFailure` aid) (EM.lookup aid actorAspect) threatDistL <- getsState $ meleeThreatDistList aid (fleeL, _) <- fleeList aid condSupport1 <- condSupport 1 aid condSupport3 <- condSupport 3 aid condSolo <- condSoloM aid -- solo fighters aggresive canDeAmbientL <- getsState $ canDeAmbientList body let condCanFlee = not (null fleeL) speed1_5 = speedScale (3%2) (gearSpeed ar) condCanMelee = actorCanMelee actorAspect aid body condThreat n = not $ null $ takeWhile ((<= n) . fst) threatDistL threatAdj = takeWhile ((== 1) . fst) threatDistL condManyThreatAdj = length threatAdj >= 2 condFastThreatAdj = any (\(_, (aid2, _)) -> let ar2 = actorAspect EM.! aid2 in gearSpeed ar2 > speed1_5) threatAdj heavilyDistressed = -- Actor hit by a projectile or similarly distressed. deltaSerious (bcalmDelta body) actorShines = IA.aShine ar > 0 aCanDeLightL | actorShines = [] | otherwise = canDeAmbientL canFleeFromLight = not $ null $ aCanDeLightL `intersect` map snd fleeL return $! -- This is a part of the condition for @flee@ in @HandleAbilityM@. not condFastThreatAdj && if | condThreat 1 -> not condCanMelee || condManyThreatAdj && not condSupport1 && not condSolo | not condInMelee && (condThreat 2 || condThreat 5 && canFleeFromLight) -> not condCanMelee || not condSupport3 && not condSolo && not heavilyDistressed -- not used: | condThreat 5 -> False -- because actor should be picked anyway, to try to melee | otherwise -> not condInMelee && heavilyDistressed && not (EM.member aid fleeD) -- Make him a leader even if can't delight, etc. -- because he may instead take off light or otherwise -- cope with being pummeled by projectiles. -- He is still vulnerable, just not necessarily needs -- to flee, but may cover himself otherwise. -- && (not condCanProject || canFleeFromLight) && condCanFlee actorFled ((aid, _), _) = EM.member aid fleeD actorHearning (_, TgtAndPath{ tapTgt=TPoint TEnemyPos{} _ _ , tapPath=NoPath }) = return False actorHearning (_, TgtAndPath{ tapTgt=TPoint TEnemyPos{} _ _ , tapPath=AndPath{pathLen} }) | pathLen <= 2 = return False -- noise probably due to fleeing target actorHearning ((_aid, b), _) = do allFoes <- getsState $ foeRegularList side (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 (oursVulnerable, oursSafe) <- partitionM actorVulnerable oursTgt let (oursFled, oursNotFled) = partition actorFled oursSafe (oursMeleeing, oursNotMeleeing) <- partitionM actorMeleeing oursNotFled (oursHearing, oursNotHearing) <- partitionM actorHearning oursNotMeleeing let actorRanged ((aid, body), _) = not $ actorCanMelee actorAspect aid body targetTEnemy (_, TgtAndPath{tapTgt=TEnemy _ permit}) = not permit targetTEnemy ( (_, b) , TgtAndPath{tapTgt=TPoint (TEnemyPos _ permit) lid _} ) = lid == blid b && not permit targetTEnemy _ = False actorNoSupport ((aid, _), _) = do threatDistL <- getsState $ meleeThreatDistList aid condSupport2 <- condSupport 2 aid let condThreat n = not $ null $ takeWhile ((<= n) . fst) threatDistL -- If foes far, friends may still come, so we let him move. -- The net effect is that lone heroes close to foes freeze -- until support comes. return $! condThreat 5 && not condSupport2 (oursRanged, oursNotRanged) = partition actorRanged oursNotHearing (oursTEnemyAll, oursOther) = partition targetTEnemy oursNotRanged notSwapReady abt@((_, b), _) (ab2, Just t2@TgtAndPath{tapPath= AndPath{pathList=q : _}}) = let source = bpos b tenemy = targetTEnemy abt tenemy2 = targetTEnemy (ab2, t2) -- Copied from 'displaceTowards': in not (q == source -- friend wants to swap || tenemy && not tenemy2) notSwapReady _ _ = True -- These are not necessarily stuck (perhaps can go around), -- but their current path is blocked by friends. targetBlocked abt@((aid, _), TgtAndPath{tapPath}) = case tapPath of AndPath{pathList= q : _} -> any (\abt2@((aid2, body2), _) -> aid2 /= aid -- in case pushed on goal && bpos body2 == q && notSwapReady abt abt2) oursTgtRaw _ -> False (oursTEnemyBlocked, oursTEnemy) = partition targetBlocked oursTEnemyAll (oursNoSupportRaw, oursSupportRaw) <- if length oursTEnemy <= 2 then return ([], oursTEnemy) else partitionM actorNoSupport oursTEnemy let (oursNoSupport, oursSupport) = if length oursSupportRaw <= 1 -- make sure picks random enough then ([], oursTEnemy) else (oursNoSupportRaw, oursSupportRaw) (oursBlocked, oursPos) = partition targetBlocked $ oursRanged ++ oursOther -- Lower overhead is better. overheadOurs :: ((ActorId, Actor), TgtAndPath) -> Int overheadOurs ((aid, _), TgtAndPath{tapPath=NoPath}) = 100 + if aid == oldAid then 1 else 0 overheadOurs abt@( (aid, b) , TgtAndPath{tapPath=AndPath{pathLen=d,pathGoal}} ) = -- Keep proper formation. Too dense and exploration takes -- too long; too sparse and actors fight alone. -- Note that right now, while we set targets separately for each -- hero, perhaps on opposite borders of the map, -- we can't help that sometimes heroes are separated. let maxSpread = 3 + length ours pDist p = minimum [ chessDist (bpos b2) p | (aid2, b2) <- ours, aid2 /= aid] aidDist = pDist (bpos b) -- Negative, if the goal gets us closer to the party. diffDist = pDist pathGoal - aidDist -- If actor already at goal or equidistant, count it as closer. sign = if diffDist <= 0 then -1 else 1 formationValue = sign * (abs diffDist `max` maxSpread) * (aidDist `max` maxSpread) ^ (2 :: Int) fightValue | targetTEnemy abt = - fromEnum (bhp b `div` (10 * oneM)) | otherwise = 0 in formationValue `div` 3 + fightValue + (if targetBlocked abt then 5 else 0) + (case d of 0 -> -400 -- do your thing ASAP and retarget 1 -> -200 -- prevent others from occupying the tile _ -> if d < 8 then d `div` 4 else 2 + d `div` 10) + (if aid == oldAid then 1 else 0) positiveOverhead ab = let ov = 200 - overheadOurs ab in if ov <= 0 then 1 else ov candidates = [ oursVulnerable , oursSupport , oursNoSupport , oursPos , oursFled -- if just fled, keep him safe, out of action , oursMeleeing ++ oursTEnemyBlocked -- make melee a leader to displace or at least melee -- without overhead if all others blocked , oursHearing , oursBlocked ] case filter (not . null) candidates of l : _ -> do let freq = toFreq "candidates for AI leader" $ map (positiveOverhead &&& id) l ((aid, b), _) <- rndToAction $ frequency freq s <- getState modifyClient $ updateLeader aid s -- When you become a leader, stop following old leader, but follow -- his target, if still valid, to avoid distraction. let condInMelee = scondInMelee LEM.! blid b when (ftactic (gplayer fact) `elem` [TFollow, TFollowNoItems] && not condInMelee) $ void $ refreshTarget (aid, b) return aid _ -> return oldAid -- | Inspect the tactics of the actor and set his target according to it. setTargetFromTactics :: MonadClient m => ActorId -> m () {-# INLINE setTargetFromTactics #-} setTargetFromTactics oldAid = do mleader <- getsClient sleader let !_A = assert (mleader /= Just oldAid) () oldBody <- getsState $ getActorBody oldAid scondInMelee <- getsClient scondInMelee let condInMelee = scondInMelee LEM.! blid oldBody let side = bfid oldBody arena = blid oldBody fact <- getsState $ (EM.! side) . sfactionD let explore = void $ refreshTarget (oldAid, oldBody) setPath mtgt = case mtgt of Nothing -> return False Just TgtAndPath{tapTgt} -> do tap <- createPath oldAid tapTgt case tap of TgtAndPath{tapPath=NoPath} -> return False _ -> do modifyClient $ \cli -> cli {stargetD = EM.insert oldAid tap (stargetD cli)} return True follow = case mleader of -- If no leader at all (forced @TFollow@ 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 || condInMelee then explore else do -- Copy over the leader's target, if any, or follow his bpos. mtgt <- getsClient $ EM.lookup leader . stargetD tgtPathSet <- setPath mtgt let enemyPath = Just TgtAndPath{ tapTgt = TEnemy leader True , tapPath = NoPath } unless tgtPathSet $ do enemyPathSet <- setPath enemyPath unless enemyPathSet -- If no path even to the leader himself, explore. explore 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 -- WIP LambdaHack-0.8.3.0/Game/LambdaHack/Client/AI/ConditionM.hs0000644000000000000000000003443413315545734020765 0ustar0000000000000000-- | Assorted conditions used later on in AI logic. module Game.LambdaHack.Client.AI.ConditionM ( condAimEnemyPresentM , condAimEnemyRememberedM , condTgtNonmovingM , condAnyFoeAdjM , condAdjTriggerableM , meleeThreatDistList , condBlocksFriendsM , condFloorWeaponM , condNoEqpWeaponM , condCanProjectM , condProjectListM , benAvailableItems , hinders , condDesirableFloorItemM , benGroundItems , desirableItem , condSupport , condSoloM , condShineWouldBetrayM , fleeList ) where import Prelude () import Game.LambdaHack.Common.Prelude import qualified Data.EnumMap.Strict as EM import Data.Ord import Game.LambdaHack.Client.Bfs import Game.LambdaHack.Client.CommonM 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 qualified Game.LambdaHack.Common.ItemAspect as IA import Game.LambdaHack.Common.Kind import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.MonadStateRead import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.ReqFailure import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile import Game.LambdaHack.Common.Time import Game.LambdaHack.Common.Vector import qualified Game.LambdaHack.Content.ItemKind as IK import Game.LambdaHack.Content.ModeKind -- All conditions are (partially) lazy, because they are not always -- used in the strict monadic computations they are in. -- | Require that the target enemy is visible by the party. condAimEnemyPresentM :: MonadClient m => ActorId -> m Bool condAimEnemyPresentM 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. condAimEnemyRememberedM :: MonadClient m => ActorId -> m Bool condAimEnemyRememberedM aid = do b <- getsState $ getActorBody aid btarget <- getsClient $ getTarget aid return $ case btarget of Just (TPoint (TEnemyPos _ permit) lid _) -> lid == blid b && not permit _ -> 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 actorMaxSk <- maxActorSkillsClient enemy return $ EM.findWithDefault 0 Ability.AbMove actorMaxSk <= 0 _ -> return False -- | Require that any non-dying foe is adjacent, except projectiles -- that (possibly) explode upon contact. condAnyFoeAdjM :: MonadStateRead m => ActorId -> m Bool condAnyFoeAdjM aid = getsState $ anyFoeAdj aid -- | Require the actor stands adjacent to a triggerable tile (e.g., stairs). condAdjTriggerableM :: MonadStateRead m => ActorId -> m Bool condAdjTriggerableM aid = do b <- getsState $ getActorBody aid lvl <- getLevel $ blid b let hasTriggerable p = p `EM.member` lembed lvl return $ any hasTriggerable $ vicinityUnsafe $ bpos b -- | Produce the chess-distance-sorted list of non-low-HP, -- melee-cabable foes on the level. We don't consider path-distance, -- because we are interested in how soon the foe can close in to hit us, -- which can diverge greately from path distance for short distances, -- e.g., when terrain gets revealed. We don't consider non-moving actors, -- because they can't chase us and also because they can't be aggresive -- so to resolve the stalemate, the opposing AI has to be aggresive -- by ignoring them and closing in to melee distance. meleeThreatDistList :: ActorId -> State -> [(Int, (ActorId, Actor))] meleeThreatDistList aid s = let actorAspect = sactorAspect s b = getActorBody aid s allAtWar = foeRegularAssocs (bfid b) (blid b) s strongActor (aid2, b2) = let ar = actorAspect EM.! aid2 actorMaxSkE = IA.aSkills ar nonmoving = EM.findWithDefault 0 Ability.AbMove actorMaxSkE <= 0 in not (hpTooLow b2 ar || nonmoving) && actorCanMelee actorAspect aid2 b2 allThreats = filter strongActor allAtWar addDist (aid2, b2) = (chessDist (bpos b) (bpos b2), (aid2, b2)) in sortBy (comparing fst) $ map addDist allThreats -- | Require the actor blocks the paths of any of his party members. condBlocksFriendsM :: MonadClient m => ActorId -> m Bool condBlocksFriendsM aid = do b <- getsState $ getActorBody aid targetD <- getsClient stargetD let blocked aid2 = aid2 /= aid && case EM.lookup aid2 targetD of Just TgtAndPath{tapPath=AndPath{pathList=q : _}} | q == bpos b -> True _ -> False any blocked <$> getsState (fidActorRegularIds (bfid b) (blid b)) -- | Require the actor stands over a weapon that would be auto-equipped. condFloorWeaponM :: MonadStateRead m => ActorId -> m Bool condFloorWeaponM aid = any (IK.isMelee . itemKind . snd) <$> getsState (fullAssocs aid [CGround]) -- | Check whether the actor has no weapon in equipment. condNoEqpWeaponM :: MonadStateRead m => ActorId -> m Bool condNoEqpWeaponM aid = all (not . IK.isMelee . itemKind . snd) <$> getsState (fullAssocs aid [CEqp]) -- | Require that the actor can project any items. condCanProjectM :: MonadClient m => Int -> ActorId -> m Bool {-# INLINE condCanProjectM #-} condCanProjectM skill aid = -- Compared to conditions in @projectItem@, range and charge are ignored, -- because they may change by the time the position for the fling is reached. not . null <$> condProjectListM skill aid condProjectListM :: MonadClient m => Int -> ActorId -> m [(Benefit, CStore, ItemId, ItemFull, ItemQuant)] {-# INLINE condProjectListM #-} condProjectListM skill aid = do condShineWouldBetray <- condShineWouldBetrayM aid condAimEnemyPresent <- condAimEnemyPresentM aid discoBenefit <- getsClient sdiscoBenefit getsState $ projectList discoBenefit skill aid condShineWouldBetray condAimEnemyPresent projectList :: DiscoveryBenefit -> Int -> ActorId -> Bool -> Bool -> State -> [(Benefit, CStore, ItemId, ItemFull, ItemQuant)] projectList discoBenefit skill aid condShineWouldBetray condAimEnemyPresent s = let b = getActorBody aid s ar = getActorAspect aid s calmE = calmEnough b ar condNotCalmEnough = not calmE heavilyDistressed = -- Actor hit by a projectile or similarly distressed. deltaSerious (bcalmDelta b) -- This detects if the value of keeping the item in eqp is in fact < 0. hind = hinders condShineWouldBetray condAimEnemyPresent heavilyDistressed condNotCalmEnough ar q (Benefit{benInEqp, benFling}, _, _, itemFull, _) = benFling < 0 && (not benInEqp -- can't wear, so OK to risk losing or breaking || not (IK.isMelee $ itemKind itemFull) -- anything else expendable && hind itemFull) -- hinders now, so possibly often, so away! && permittedProjectAI skill calmE itemFull stores = [CEqp, CInv, CGround] ++ [CSha | calmE] in filter q $ benAvailableItems discoBenefit aid stores s -- | Produce the list of items with a given property available to the actor -- and the items' values. benAvailableItems :: DiscoveryBenefit -> ActorId -> [CStore] -> State -> [(Benefit, CStore, ItemId, ItemFull, ItemQuant)] benAvailableItems discoBenefit aid cstores s = let b = getActorBody aid s ben cstore bag = [ (discoBenefit EM.! iid, cstore, iid, itemToFull iid s, kit) | (iid, kit) <- EM.assocs bag] benCStore cs = ben cs $ getBodyStoreBag b cs s in concatMap benCStore cstores hinders :: Bool -> Bool -> Bool -> Bool -> IA.AspectRecord -> ItemFull -> Bool hinders condShineWouldBetray condAimEnemyPresent heavilyDistressed condNotCalmEnough -- guess that enemies have projectiles and used them now or recently ar itemFull = let itemShine = 0 < IA.aShine (aspectRecordFull itemFull) -- @condAnyFoeAdj@ is not checked, because it's transient and also item -- management is unlikely to happen during melee, anyway itemShineBad = condShineWouldBetray && itemShine in -- In the presence of enemies (seen, or unseen but distressing) -- actors want to hide in the dark. (condAimEnemyPresent || condNotCalmEnough || heavilyDistressed) && itemShineBad -- even if it's a weapon, take it off -- Fast actors want to hit hard, because they hit much more often -- than receive hits. || gearSpeed ar > speedWalk && not (IK.isMelee $ itemKind itemFull) -- in case it's the only weapon && 0 > IA.aHurtMelee (aspectRecordFull itemFull) -- | Require that the actor stands over a desirable item. condDesirableFloorItemM :: MonadClient m => ActorId -> m Bool condDesirableFloorItemM aid = not . null <$> benGroundItems aid -- | Produce the list of items on the ground beneath the actor -- that are worth picking up. benGroundItems :: MonadClient m => ActorId -> m [(Benefit, CStore, ItemId, ItemFull, ItemQuant)] benGroundItems aid = do b <- getsState $ getActorBody aid fact <- getsState $ (EM.! bfid b) . sfactionD discoBenefit <- getsClient sdiscoBenefit let canEsc = fcanEscape (gplayer fact) isDesirable (ben, _, _, ItemFull{itemKind}, _) = desirableItem canEsc (benPickup ben) itemKind filter isDesirable <$> getsState (benAvailableItems discoBenefit aid [CGround]) desirableItem :: Bool -> Double -> IK.ItemKind -> Bool desirableItem canEsc benPickup itemKind = if canEsc then benPickup > 0 || IK.Precious `elem` IK.ifeature itemKind else -- A hack to prevent monsters from picking up treasure meant for heroes. let preciousNotUseful = IK.isHumanTrinket itemKind in benPickup > 0 && not preciousNotUseful condSupport :: MonadClient m => Int -> ActorId -> m Bool {-# INLINE condSupport #-} condSupport param aid = do btarget <- getsClient $ getTarget aid condAimEnemyPresent <- condAimEnemyPresentM aid condAimEnemyRemembered <- condAimEnemyRememberedM aid getsState $ strongSupport param aid btarget condAimEnemyPresent condAimEnemyRemembered strongSupport :: Int -> ActorId -> Maybe Target -> Bool -> Bool -> State -> Bool strongSupport param aid btarget condAimEnemyPresent condAimEnemyRemembered s = -- The smaller the area scanned for friends, the lower number required. let n = min 2 param - IA.aAggression ar actorAspect = sactorAspect s ar = actorAspect EM.! aid b = getActorBody aid s mtgtPos = case btarget of Nothing -> Nothing Just target -> aidTgtToPos aid (blid b) target s approaching b2 = case mtgtPos of Just tgtPos | condAimEnemyPresent || condAimEnemyRemembered -> chessDist (bpos b2) tgtPos <= 1 + param _ -> False closeEnough b2 = let dist = chessDist (bpos b) (bpos b2) in dist > 0 && (dist <= param || approaching b2) closeAndStrong (aid2, b2) = closeEnough b2 && actorCanMelee actorAspect aid2 b2 friends = friendRegularAssocs (bfid b) (blid b) s closeAndStrongFriends = filter closeAndStrong friends in not $ n > 0 && null (drop (n - 1) closeAndStrongFriends) -- optimized: length closeAndStrongFriends >= n condSoloM :: MonadClient m => ActorId -> m Bool condSoloM aid = do b <- getsState $ getActorBody aid let isSingleton [_] = True isSingleton _ = False isSingleton <$> getsState (friendRegularList (bfid b) (blid b)) -- | Require that the actor stands in the dark and so would be betrayed -- by his own equipped light, condShineWouldBetrayM :: MonadStateRead m => ActorId -> m Bool condShineWouldBetrayM aid = do b <- getsState $ getActorBody aid aInAmbient <- getsState $ actorInAmbient b return $ not aInAmbient -- tile is dark, so actor could hide -- | Produce a list of acceptable adjacent points to flee to. fleeList :: MonadClient m => ActorId -> m ([(Int, Point)], [(Int, Point)]) fleeList aid = do COps{coTileSpeedup} <- getsState scops mtgtMPath <- getsClient $ EM.lookup aid . stargetD -- Prefer fleeing along the path to target, unless the target is a foe, -- in which case flee in the opposite direction. let etgtPath = case mtgtMPath of Just TgtAndPath{ tapPath=tapPath@AndPath{pathList} , tapTgt } -> case tapTgt of TEnemy{} -> Left tapPath TPoint TEnemyPos{} _ _ -> Left tapPath _ -> Right pathList _ -> Right [] b <- getsState $ getActorBody aid lvl@Level{lxsize, lysize} <- getLevel $ blid b s <- getState let posFoes = map bpos $ foeRegularList (bfid b) (blid b) s myVic = vicinity lxsize lysize $ bpos b dist p | null posFoes = 100 | otherwise = minimum $ map (chessDist p) posFoes dVic = map (dist &&& id) myVic -- Flee, if possible. Direct access required; not enough time to open. -- Can't be occupied. accUnocc p = Tile.isWalkable coTileSpeedup (lvl `at` p) && null (posToAssocs p (blid b) s) accVic = filter (accUnocc . 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) = case etgtPath of Right tgtPath | p `elem` tgtPath -> (100 * mult * d, p) Right tgtPath | any (adjacent p) tgtPath -> (10 * mult * d, p) Left AndPath{pathGoal} | bpos b /= pathGoal -> let venemy = towards (bpos b) pathGoal vflee = towards (bpos b) p sq = euclidDistSqVector venemy vflee skew = case compare sq 2 of GT -> 100 * sq EQ -> 10 * sq LT -> sq -- going towards enemy (but may escape adjacent foes) in (mult * skew * d, p) _ -> (mult * d, p) -- far from target path or even on target goal goodVic = map (rewardPath 10000) gtVic ++ map (rewardPath 100) eqVic badVic = map (rewardPath 1) ltVic return (goodVic, badVic) LambdaHack-0.8.3.0/Game/LambdaHack/Client/AI/Strategy.hs0000644000000000000000000000722313315545734020520 0ustar0000000000000000{-# LANGUAGE DeriveFoldable, DeriveTraversable, TupleSections #-} -- | AI strategies to direct actors not controlled directly by human players. -- No operation in this module involves the 'State' tyep or any of our -- client/server monads types. module Game.LambdaHack.Client.AI.Strategy ( Strategy, nullStrategy, liftFrequency , (.|), reject, (.=>), only, bestVariant, renameStrategy, returN, mapStrategyM ) where import Prelude () import Game.LambdaHack.Common.Prelude import Control.Applicative import Data.Int (Int32) import Game.LambdaHack.Common.Frequency as Frequency -- | A strategy is a choice of (non-empty) frequency tables -- of possible actions. newtype Strategy a = Strategy { runStrategy :: [Frequency a] } deriving (Show, Foldable, Traversable) _maxBound32 :: Integer _maxBound32 = toInteger (maxBound :: Int32) instance Monad Strategy where m >>= f = normalizeStrategy $ Strategy [ toFreq name [ #ifdef WITH_EXPENSIVE_ASSERTIONS assert (toInteger p * toInteger q <= _maxBound32) #endif (p * q, b) | (p, a) <- runFrequency x , y <- runStrategy (f a) , (q, b) <- runFrequency y ] | x <- runStrategy m , let name = "Strategy_bind (" <> nameFrequency x <> ")"] instance Functor Strategy where fmap f (Strategy fs) = Strategy (map (fmap f) fs) instance Applicative Strategy where {-# INLINE pure #-} pure x = Strategy $ return $! uniformFreq "Strategy_pure" [x] (<*>) = ap instance MonadPlus Strategy where mzero = Strategy [] mplus (Strategy xs) (Strategy ys) = Strategy (xs ++ ys) instance Alternative Strategy where (<|>) = mplus empty = mzero normalizeStrategy :: Strategy a -> Strategy a normalizeStrategy (Strategy fs) = Strategy $ filter (not . nullFreq) fs nullStrategy :: Strategy a -> Bool nullStrategy strat = null $ runStrategy strat -- | Strategy where only the actions from the given single frequency table -- can be picked. liftFrequency :: Frequency a -> Strategy a liftFrequency f = normalizeStrategy $ Strategy $ return f infixr 2 .| -- | Strategy with the actions from both argument strategies, -- with original frequencies. (.|) :: Strategy a -> Strategy a -> Strategy a (.|) = mplus -- | Strategy with no actions at all. reject :: Strategy a reject = mzero infix 3 .=> -- | Conditionally accepted strategy. (.=>) :: Bool -> Strategy a -> Strategy a p .=> m | p = m | otherwise = mzero -- | Strategy with all actions not satisfying the predicate removed. -- The remaining actions keep their original relative frequency values. only :: (a -> Bool) -> Strategy a -> Strategy a only p s = normalizeStrategy $ do x <- s p x .=> return x -- | When better choices are towards the start of the list, -- this is the best frequency of the strategy. bestVariant :: Strategy a -> Frequency a bestVariant (Strategy []) = mzero bestVariant (Strategy (f : _)) = f -- | Overwrite the description of all frequencies within the strategy. renameStrategy :: Text -> Strategy a -> Strategy a renameStrategy newName (Strategy fs) = Strategy $ map (renameFreq newName) fs -- | Like 'return', but pick a name of the single frequency. returN :: Text -> a -> Strategy a returN name x = Strategy $ return $! uniformFreq name [x] mapStrategyM :: Monad m => (a -> m (Maybe b)) -> Strategy a -> m (Strategy b) mapStrategyM f s = do let mapFreq freq = do let g (k, a) = do mb <- f a return $! (k,) <$> mb lbm <- mapM g $ runFrequency freq return $! toFreq "mapStrategyM" $ catMaybes lbm ls = runStrategy s lt <- mapM mapFreq ls return $! normalizeStrategy $ Strategy lt LambdaHack-0.8.3.0/Game/LambdaHack/Client/UI/0000755000000000000000000000000013315545734016402 5ustar0000000000000000LambdaHack-0.8.3.0/Game/LambdaHack/Client/UI/Animation.hs0000644000000000000000000001762713315545734020672 0ustar0000000000000000-- | Screen frames and animations. module Game.LambdaHack.Client.UI.Animation ( Animation, renderAnim , pushAndDelay, blinkColorActor, twirlSplash, blockHit, blockMiss, subtleHit , deathBody, shortDeathBody, actorX, teleport, swapPlaces, fadeout #ifdef EXPOSE_INTERNAL -- * Internal operations , blank, cSym, mapPosToOffset, mzipSingleton, mzipPairs #endif ) where import Prelude () import Game.LambdaHack.Common.Prelude import Data.Bits import qualified Data.EnumMap.Strict as EM import Game.LambdaHack.Client.UI.Frame import Game.LambdaHack.Client.UI.Overlay import Game.LambdaHack.Common.Color import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.Random -- | 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 [IntOverlay] deriving (Eq, Show) -- | Render animations on top of a screen frame. -- -- Located in this module to keep @Animation@ abstract. renderAnim :: FrameForall -> Animation -> Frames renderAnim basicFrame (Animation anim) = let modifyFrame :: IntOverlay -> FrameForall modifyFrame am = overlayFrame am basicFrame modifyFrames :: (IntOverlay, IntOverlay) -> Maybe FrameForall modifyFrames (am, amPrevious) = if am == amPrevious then Nothing else Just $ modifyFrame am in Just basicFrame : map modifyFrames (zip anim ([] : anim)) blank :: Maybe AttrCharW32 blank = Nothing cSym :: Color -> Char -> Maybe AttrCharW32 cSym color symbol = Just $ attrChar2ToW32 color symbol mapPosToOffset :: (Point, AttrCharW32) -> (Int, [AttrCharW32]) mapPosToOffset (Point{..}, attr) = let lxsize = fst normalLevelBound + 1 in ((py + 1) * lxsize + px, [attr]) mzipSingleton :: Point -> Maybe AttrCharW32 -> IntOverlay mzipSingleton p1 mattr1 = map mapPosToOffset $ let mzip (pos, mattr) = fmap (\attr -> (pos, attr)) mattr in catMaybes [mzip (p1, mattr1)] mzipPairs :: (Point, Point) -> (Maybe AttrCharW32, Maybe AttrCharW32) -> IntOverlay mzipPairs (p1, p2) (mattr1, mattr2) = map mapPosToOffset $ let mzip (pos, mattr) = fmap (\attr -> (pos, attr)) 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)] pushAndDelay :: Animation pushAndDelay = Animation [[]] blinkColorActor :: Point -> Char -> Color -> Color -> Animation blinkColorActor pos symbol fromCol toCol = Animation $ map (mzipSingleton pos) [ cSym toCol symbol , cSym toCol symbol , cSym fromCol symbol , cSym fromCol symbol ] -- | Attack animation. A part of it also reused for self-damage and healing. twirlSplash :: (Point, Point) -> Color -> Color -> Animation twirlSplash poss c1 c2 = Animation $ map (mzipPairs poss) [ (blank , cSym BrCyan '\'') , (blank , cSym 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) ] -- | Attack that hits through a block. blockHit :: (Point, Point) -> Color -> Color -> Animation blockHit poss c1 c2 = Animation $ map (mzipPairs poss) [ (blank , cSym BrCyan '\'') , (blank , cSym 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 (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) ] -- | Attack that is subtle (e.g., damage dice 0). subtleHit :: Point -> Animation subtleHit pos = Animation $ map (mzipSingleton pos) [ cSym BrCyan '\'' , cSym BrYellow '\'' , cSym BrYellow '^' , cSym BrCyan '^' , cSym BrCyan '\'' ] -- | Death animation for an organic body. deathBody :: Point -> Animation deathBody pos = Animation $ map (mzipSingleton pos) [ cSym Red '%' , cSym Red '-' , cSym Red '-' , cSym Red '\\' , cSym Red '\\' , cSym Red '|' , cSym Red '|' , cSym Red '%' , cSym Red '%' , cSym Red '%' , cSym Red '%' , cSym Red ';' , cSym Red ';' ] -- | Death animation for an organic body, short version (e.g., for enemies). shortDeathBody :: Point -> Animation shortDeathBody pos = Animation $ map (mzipSingleton pos) [ cSym Red '%' , cSym Red '-' , cSym Red '\\' , cSym Red '|' , cSym Red '%' , cSym Red '%' , cSym Red '%' , cSym Red ';' , cSym Red ',' ] -- | Mark actor location animation. actorX :: Point -> Animation actorX pos = Animation $ map (mzipSingleton pos) [ cSym BrRed 'X' , cSym BrRed 'X' , blank , blank ] -- | Actor teleport animation. teleport :: (Point, Point) -> Animation teleport poss = Animation $ map (mzipPairs poss) [ (cSym BrMagenta 'o', cSym Magenta '.') , (cSym BrMagenta 'O', cSym Magenta '.') , (cSym Magenta 'o', cSym Magenta 'o') , (cSym Magenta '.', cSym BrMagenta 'O') , (cSym Magenta '.', cSym BrMagenta 'o') , (cSym Magenta '.', blank) , (blank , blank) ] -- | Swap-places animation, both hostile and friendly. swapPlaces :: (Point, Point) -> Animation swapPlaces poss = Animation $ map (mzipPairs poss) [ (cSym BrMagenta 'o', cSym Magenta 'o') , (cSym BrMagenta 'd', cSym Magenta 'p') , (cSym BrMagenta '.', cSym Magenta 'p') , (cSym Magenta 'p', cSym Magenta '.') , (cSym Magenta 'p', cSym BrMagenta 'd') , (cSym Magenta 'p', cSym BrMagenta 'd') , (cSym Magenta 'o', blank) , (blank , blank) ] fadeout :: Bool -> Int -> X -> Y -> Rnd Animation fadeout out step lxsize lysize = do let xbound = lxsize - 1 ybound = lysize + 2 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 fadeAttr !y !x = attrChar1ToW32 $ fadeChar r n x y fadeLine !y = let x1 :: Int {-# INLINE x1 #-} x1 = min xbound (n - 2 * (ybound - y)) x2 :: Int {-# INLINE x2 #-} x2 = max 0 (xbound - (n - 2 * y)) in [ (y * lxsize, map (fadeAttr y) [0..x1]) , (y * lxsize + x2, map (fadeAttr y) [x2..xbound]) ] return $! concatMap fadeLine [0..ybound] fs | out = [3, 3 + step .. lxsize - 14] | otherwise = [lxsize - 14, lxsize - 14 - step .. 1] ++ [0] -- no remnants of fadein onscreen, in case of lag Animation <$> mapM rollFrame fs LambdaHack-0.8.3.0/Game/LambdaHack/Client/UI/FrameM.hs0000644000000000000000000001416513315545734020114 0ustar0000000000000000-- | A set of Frame monad operations. module Game.LambdaHack.Client.UI.FrameM ( pushFrame, promptGetKey, stopPlayBack, animate, fadeOutOrIn #ifdef EXPOSE_INTERNAL -- * Internal operations , drawOverlay, renderFrames #endif ) where import Prelude () import Game.LambdaHack.Common.Prelude import qualified Data.EnumMap.Strict as EM import Game.LambdaHack.Client.ClientOptions import Game.LambdaHack.Client.MonadClient import Game.LambdaHack.Client.State import Game.LambdaHack.Client.UI.Animation import Game.LambdaHack.Client.UI.DrawM import Game.LambdaHack.Client.UI.Frame import qualified Game.LambdaHack.Client.UI.Key as K import Game.LambdaHack.Client.UI.MonadClientUI import Game.LambdaHack.Client.UI.Msg import Game.LambdaHack.Client.UI.MsgM import Game.LambdaHack.Client.UI.Overlay import Game.LambdaHack.Client.UI.SessionUI import Game.LambdaHack.Client.UI.UIOptions import Game.LambdaHack.Common.ActorState import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.MonadStateRead import Game.LambdaHack.Common.State -- | Draw the current level with the overlay on top. -- If the overlay is too long, it's truncated. -- Similarly, for each line of the overlay, if it's too wide, it's truncated. drawOverlay :: MonadClientUI m => ColorMode -> Bool -> Overlay -> LevelId -> m FrameForall drawOverlay dm onBlank topTrunc lid = do mbaseFrame <- if onBlank then return $ FrameForall $ \_v -> return () else drawBaseFrame dm lid return $! overlayFrameWithLines onBlank topTrunc mbaseFrame -- | Push the frame depicting the current level to the frame queue. -- Only one line of the report is shown, as in animations, -- because it may not be our turn, so we can't clear the message -- to see what is underneath. pushFrame :: MonadClientUI m => m () pushFrame = do -- The delay before reaction to keypress was too long in case of many -- projectiles flying and ending flight, so frames need to be skipped. keyPressed <- anyKeyPressed unless keyPressed $ do lidV <- viewedLevelUI report <- getReportUI let truncRep = [renderReport report] frame <- drawOverlay ColorFull False truncRep lidV displayFrames lidV [Just frame] promptGetKey :: MonadClientUI m => ColorMode -> Overlay -> Bool -> [K.KM] -> m K.KM promptGetKey dm ov onBlank frontKeyKeys = do lidV <- viewedLevelUI keyPressed <- anyKeyPressed lastPlayOld <- getsSession slastPlay km <- case lastPlayOld of km : kms | not keyPressed && (null frontKeyKeys || km `elem` frontKeyKeys) -> do frontKeyFrame <- drawOverlay dm onBlank ov lidV displayFrames lidV [Just frontKeyFrame] modifySession $ \sess -> sess {slastPlay = kms} UIOptions{uRunStopMsgs} <- getsSession sUIOptions when uRunStopMsgs $ promptAdd0 $ "Voicing '" <> tshow km <> "'." return km _ : _ -> do -- We can't continue playback, so wipe out old slastPlay, srunning, etc. stopPlayBack discardPressedKey let ov2 = ov `glueLines` [stringToAL "*interrupted*" | keyPressed] frontKeyFrame <- drawOverlay dm onBlank ov2 lidV connFrontendFrontKey frontKeyKeys frontKeyFrame [] -> do -- If we ask for a key, then we don't want to run any more -- and we want to avoid changing leader back to initial run leader -- at the nearest @stopPlayBack@, etc. modifySession $ \sess -> sess {srunning = Nothing} frontKeyFrame <- drawOverlay dm onBlank ov lidV connFrontendFrontKey frontKeyKeys frontKeyFrame LastRecord seqCurrent seqPrevious k <- getsSession slastRecord let slastRecord = LastRecord (km : seqCurrent) seqPrevious k modifySession $ \sess -> sess { slastRecord , sdisplayNeeded = False } return km stopPlayBack :: MonadClientUI m => m () stopPlayBack = do lastPlayOld <- getsSession slastPlay unless (null lastPlayOld) $ do modifySession $ \sess -> sess {slastPlay = []} LastRecord _ _ k <- getsSession slastRecord when (k > 0) $ do -- Needed to properly cancel macros that contain apostrophes. modifySession $ \sess -> sess {slastRecord = LastRecord [] [] 0} promptAdd0 "Macro recording aborted." srunning <- getsSession srunning case srunning of Nothing -> return () Just RunParams{runLeader} -> do -- Switch to the original leader, from before the run start, -- unless dead or unless the faction never runs with multiple -- (but could have the leader changed automatically meanwhile). side <- getsClient sside fact <- getsState $ (EM.! side) . sfactionD arena <- getArenaUI s <- getState when (memActor runLeader arena s && not (noRunWithMulti fact)) $ modifyClient $ updateLeader runLeader s modifySession (\sess -> sess {srunning = Nothing}) -- | Render animations on top of the current screen frame. renderFrames :: MonadClientUI m => LevelId -> Animation -> m Frames renderFrames arena anim = do report <- getReportUI let truncRep = [renderReport report] basicFrame <- drawOverlay ColorFull False truncRep arena snoAnim <- getsClient $ snoAnim . soptions return $! if fromMaybe False snoAnim then [Just basicFrame] else renderAnim basicFrame anim -- | Render and display animations on top of the current screen frame. animate :: MonadClientUI m => LevelId -> Animation -> m () animate arena anim = do -- The delay before reaction to keypress was too long in case of many -- projectiles hitting actors, so frames need to be skipped. keyPressed <- anyKeyPressed unless keyPressed $ do frames <- renderFrames arena anim displayFrames arena frames fadeOutOrIn :: MonadClientUI m => Bool -> m () fadeOutOrIn out = do arena <- getArenaUI Level{lxsize, lysize} <- getLevel arena animMap <- rndToActionForget $ fadeout out 2 lxsize lysize animFrs <- renderFrames arena animMap displayFrames arena (tail animFrs) -- no basic frame between fadeout and in LambdaHack-0.8.3.0/Game/LambdaHack/Client/UI/HandleHumanLocalM.hs0000644000000000000000000011743713315545734022227 0ustar0000000000000000-- | Semantics of "Game.LambdaHack.Client.UI.HumanCmd" -- client commands that do not return server requests,, -- but only change internal client state. -- None of such commands takes game time. module Game.LambdaHack.Client.UI.HandleHumanLocalM ( -- * Meta commands macroHuman -- * Local commands , sortSlotsHuman, chooseItemHuman, chooseItemDialogMode , chooseItemProjectHuman, chooseItemApplyHuman , psuitReq, triggerSymbols, permittedApplyClient , pickLeaderHuman, pickLeaderWithPointerHuman , memberCycleHuman, memberBackHuman , selectActorHuman, selectNoneHuman, selectWithPointerHuman , repeatHuman, recordHuman, historyHuman , markVisionHuman, markSmellHuman, markSuspectHuman, printScreenHuman -- * Commands specific to aiming , cancelHuman, acceptHuman, tgtClearHuman, itemClearHuman , moveXhairHuman, aimTgtHuman, aimFloorHuman, aimEnemyHuman, aimItemHuman , aimAscendHuman, epsIncrHuman , xhairUnknownHuman, xhairItemHuman, xhairStairHuman , xhairPointerFloorHuman, xhairPointerEnemyHuman , aimPointerFloorHuman, aimPointerEnemyHuman #ifdef EXPOSE_INTERNAL -- * Internal operations , permittedProjectClient, projectCheck, xhairLegalEps, posFromXhair , selectAid, endAiming, endAimingMsg, doLook, flashAiming , xhairPointerFloor, xhairPointerEnemy #endif ) where import Prelude () import Game.LambdaHack.Common.Prelude import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES import Data.Ord import qualified Data.Text as T import qualified NLP.Miniutter.English as MU import Game.LambdaHack.Client.BfsM import Game.LambdaHack.Client.CommonM import Game.LambdaHack.Client.MonadClient import Game.LambdaHack.Client.State import Game.LambdaHack.Client.UI.ActorUI import Game.LambdaHack.Client.UI.Animation import Game.LambdaHack.Client.UI.DrawM import Game.LambdaHack.Client.UI.EffectDescription import Game.LambdaHack.Client.UI.FrameM import Game.LambdaHack.Client.UI.HandleHelperM import Game.LambdaHack.Client.UI.HumanCmd import Game.LambdaHack.Client.UI.InventoryM import Game.LambdaHack.Client.UI.ItemDescription import Game.LambdaHack.Client.UI.ItemSlot import qualified Game.LambdaHack.Client.UI.Key as K import Game.LambdaHack.Client.UI.MonadClientUI import Game.LambdaHack.Client.UI.Msg import Game.LambdaHack.Client.UI.MsgM import Game.LambdaHack.Client.UI.Overlay import Game.LambdaHack.Client.UI.SessionUI import Game.LambdaHack.Client.UI.SlideshowM import Game.LambdaHack.Client.UI.UIOptions 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 qualified Game.LambdaHack.Common.ItemAspect as IA import Game.LambdaHack.Common.Kind import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.MonadStateRead import Game.LambdaHack.Common.Perception import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.ReqFailure import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile import Game.LambdaHack.Common.Time import Game.LambdaHack.Common.Vector import qualified Game.LambdaHack.Content.ItemKind as IK import Game.LambdaHack.Content.ModeKind (fhasGender) -- * Macro macroHuman :: MonadClientUI m => [String] -> m () macroHuman kms = do modifySession $ \sess -> sess {slastPlay = map K.mkKM kms ++ slastPlay sess} UIOptions{uRunStopMsgs} <- getsSession sUIOptions when uRunStopMsgs $ promptAdd1 $ "Macro activated:" <+> T.pack (intercalate " " kms) -- * SortSlots sortSlotsHuman :: MonadClientUI m => m () sortSlotsHuman = do leader <- getLeaderUI b <- getsState $ getActorBody leader sortSlots (bfid b) (Just b) promptAdd1 "Items sorted by kind and stats." -- * ChooseItem -- | Display items from a given container store and possibly let the user -- chose one. chooseItemHuman :: MonadClientUI m => ItemDialogMode -> m MError chooseItemHuman c = either Just (const Nothing) <$> chooseItemDialogMode c chooseItemDialogMode :: MonadClientUI m => ItemDialogMode -> m (FailOrCmd ItemDialogMode) chooseItemDialogMode c = do let subject = partActor verbSha body ar = if calmEnough body ar then "notice" else "paw distractedly" prompt body bodyUI ar c2 = let (tIn, t) = ppItemDialogMode c2 in case c2 of MStore CGround -> makePhrase [ MU.Capitalize $ MU.SubjectVerbSg (subject bodyUI) "notice" , MU.Text "at" , MU.WownW (MU.Text $ bpronoun bodyUI) $ MU.Text "feet" ] MStore CSha -> makePhrase [ MU.Capitalize $ MU.SubjectVerbSg (subject bodyUI) (verbSha body ar) , MU.Text tIn , MU.Text t ] MOrgans -> makePhrase [ MU.Capitalize $ MU.SubjectVerbSg (subject bodyUI) "feel" , MU.Text tIn , MU.WownW (MU.Text $ bpronoun bodyUI) $ MU.Text t ] MOwned -> makePhrase [ MU.Capitalize $ MU.SubjectVerbSg (subject bodyUI) "recall" , MU.Text tIn , MU.Text t ] MStats -> makePhrase [ MU.Capitalize $ MU.SubjectVerbSg (subject bodyUI) "estimate" , MU.WownW (MU.Text $ bpronoun bodyUI) $ MU.Text t ] MLore{} -> makePhrase [ MU.Capitalize $ MU.SubjectVerbSg (subject bodyUI) "recall" , MU.Text t ] _ -> makePhrase [ MU.Capitalize $ MU.SubjectVerbSg (subject bodyUI) "see" , MU.Text tIn , MU.WownW (MU.Text $ bpronoun bodyUI) $ MU.Text t ] ggi <- getStoreItem prompt c recordHistory -- item chosen, wipe out already shown msgs lidV <- viewedLevelUI leader <- getLeaderUI b <- getsState $ getActorBody leader bUI <- getsSession $ getActorUI leader itemToF <- getsState $ flip itemToFull localTime <- getsState $ getLocalTime (blid b) factionD <- getsState sfactionD ar <- getsState $ getActorAspect leader Level{lxsize, lysize} <- getLevel lidV case ggi of (Right (iid, itemBag, lSlots), (c2, _)) -> do let lSlotsElems = EM.elems lSlots lSlotsBound = length lSlotsElems - 1 displayLore slotIndex promptFun = do let iid2 = lSlotsElems !! slotIndex itemFull2 = itemToF iid2 kit2 = itemBag EM.! iid2 attrLine = itemDesc True (bfid b) factionD (IA.aHurtMelee ar) CGround localTime itemFull2 kit2 ov = splitAttrLine lxsize attrLine keys = [K.spaceKM, K.escKM] ++ [K.upKM | slotIndex /= 0] ++ [K.downKM | slotIndex /= lSlotsBound] promptAdd0 $ promptFun $ itemKind itemFull2 slides <- overlayToSlideshow (lysize + 1) keys (ov, []) km <- getConfirms ColorFull keys slides case K.key km of K.Space -> chooseItemDialogMode c2 K.Up -> displayLore (slotIndex - 1) promptFun K.Down -> displayLore (slotIndex + 1) promptFun K.Esc -> failWith "never mind" _ -> error $ "" `showFailure` km ix0 = fromJust $ findIndex (== iid) lSlotsElems case c2 of MStore fromCStore -> do modifySession $ \sess -> sess {sitemSel = Just (iid, fromCStore, False)} return $ Right c2 MOrgans -> do let blurb itemKind | IK.isTmpCondition itemKind = "condition" | otherwise = "organ" prompt2 itemKind = makeSentence [ partActor bUI, "can't remove" , MU.AW $ blurb itemKind ] displayLore ix0 prompt2 MOwned -> do found <- getsState $ findIid leader (bfid b) iid let (newAid, bestStore) = case leader `lookup` found of Just (_, store) -> (leader, store) Nothing -> case found of (aid, (_, store)) : _ -> (aid, store) [] -> error $ "" `showFailure` iid modifySession $ \sess -> sess {sitemSel = Just (iid, bestStore, False)} arena <- getArenaUI b2 <- getsState $ getActorBody newAid fact <- getsState $ (EM.! bfid b2) . sfactionD let (autoDun, _) = autoDungeonLevel fact if | blid b2 /= arena && autoDun -> failSer NoChangeDunLeader | otherwise -> do -- We switch leader only here, not in lore screens, because -- lore is only about inspecting items, no activation submenu. void $ pickLeader True newAid return $ Right c2 MStats -> error $ "" `showFailure` ggi MLore slore -> displayLore ix0 $ const $ makeSentence [ MU.SubjectVerbSg (partActor bUI) "remember" , MU.Text (ppSLore slore), "lore" ] (Left err, (MStats, ekm)) -> case ekm of Right slot0 -> assert (err == "stats") $ do let statListBound = length statSlots - 1 displayOneStat slotIndex = do let slot = allSlots !! slotIndex eqpSlot = statSlots !! fromJust (elemIndex slot allSlots) valueText = slotToDecorator eqpSlot b $ IA.prEqpSlot eqpSlot ar prompt2 = makeSentence [ MU.WownW (partActor bUI) (MU.Text $ slotToName eqpSlot) , "is", MU.Text valueText ] ov0 = indentSplitAttrLine lxsize $ textToAL $ slotToDesc eqpSlot keys = [K.spaceKM, K.escKM] ++ [K.upKM | slotIndex /= 0] ++ [K.downKM | slotIndex /= statListBound] promptAdd0 prompt2 slides <- overlayToSlideshow (lysize + 1) keys (ov0, []) km <- getConfirms ColorFull keys slides case K.key km of K.Space -> chooseItemDialogMode MStats K.Up -> displayOneStat $ slotIndex - 1 K.Down -> displayOneStat $ slotIndex + 1 K.Esc -> failWith "never mind" _ -> error $ "" `showFailure` km slotIndex0 = fromMaybe (error "displayOneStat: illegal slot") $ elemIndex slot0 allSlots displayOneStat slotIndex0 Left _ -> failWith "never mind" (Left err, _) -> failWith err -- * ChooseItemProject chooseItemProjectHuman :: forall m. MonadClientUI m => [TriggerItem] -> m MError chooseItemProjectHuman ts = do leader <- getLeaderUI b <- getsState $ getActorBody leader ar <- getsState $ getActorAspect leader let calmE = calmEnough b ar cLegalRaw = [CGround, CInv, CSha, CEqp] cLegal | calmE = cLegalRaw | otherwise = delete CSha cLegalRaw (verb1, object1) = case ts of [] -> ("aim", "item") tr : _ -> (tiverb tr, tiobject tr) triggerSyms = triggerSymbols ts mpsuitReq <- psuitReq case mpsuitReq of -- If xhair aim invalid, no item is considered a (suitable) missile. Left err -> failMsg err Right psuitReqFun -> do itemSel <- getsSession sitemSel case itemSel of Just (_, _, True) -> return Nothing Just (iid, fromCStore, False) -> do itemFull <- getsState $ itemToFull iid bag <- getsState $ getBodyStoreBag b fromCStore case iid `EM.lookup` bag of Just _ | either (const False) snd (psuitReqFun itemFull) -> return Nothing _ -> do modifySession $ \sess -> sess {sitemSel = Nothing} chooseItemProjectHuman ts Nothing -> do let psuit = return $ SuitsSomething $ \itemFull _kit -> either (const False) snd (psuitReqFun itemFull) && (null triggerSyms || IK.isymbol (itemKind itemFull) `elem` triggerSyms) prompt = makePhrase ["What", object1, "to", verb1] promptGeneric = "What to fling" ggi <- getGroupItem psuit prompt promptGeneric cLegalRaw cLegal case ggi of Right ((iid, _itemFull), (MStore fromCStore, _)) -> do modifySession $ \sess -> sess {sitemSel = Just (iid, fromCStore, False)} return Nothing Left err -> failMsg err _ -> error $ "" `showFailure` ggi permittedProjectClient :: MonadClientUI m => m (ItemFull -> Either ReqFailure Bool) permittedProjectClient = do leader <- getLeaderUI b <- getsState $ getActorBody leader ar <- getsState $ getActorAspect leader actorSk <- leaderSkillsClientUI let skill = EM.findWithDefault 0 AbProject actorSk calmE = calmEnough b ar return $ permittedProject False skill calmE projectCheck :: MonadClientUI m => Point -> m (Maybe ReqFailure) projectCheck tpos = do COps{coTileSpeedup} <- 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 [] -> error $ "project from the edge of level" `showFailure` (spos, tpos, sb) Just (pos : _) -> do lvl <- getLevel lid let t = lvl `at` pos if not $ Tile.isWalkable coTileSpeedup t then return $ Just ProjectBlockTerrain else do lab <- getsState $ posToAssocs pos lid if all (bproj . snd) lab then return Nothing else return $ Just ProjectBlockActor -- | Check whether one is permitted to aim (for projecting) at a target -- (this is only checked for actor targets so that the player doesn't miss -- enemy getting out of sight; but for positions we let player -- shoot at obstacles, e.g., to destroy them, and shoot at a lying item -- and then at its posision, after enemy picked up the item). -- 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. xhairLegalEps :: MonadClientUI m => m (Either Text Int) xhairLegalEps = do leader <- getLeaderUI b <- getsState $ getActorBody leader lidV <- viewedLevelUI let !_A = assert (lidV == blid b) () findNewEps onlyFirst pos = do oldEps <- getsClient seps mnewEps <- makeLine onlyFirst b pos oldEps return $! case mnewEps of Just newEps -> Right newEps Nothing -> Left $ if onlyFirst then "aiming blocked at the first step" else "aiming line blocked somewhere" xhair <- getsSession sxhair case xhair of TEnemy a _ -> do body <- getsState $ getActorBody a let pos = bpos body if blid body == lidV then findNewEps False pos else error $ "" `showFailure` (xhair, body, lidV) TPoint TEnemyPos{} _ _ -> return $ Left "selected opponent not visible" TPoint _ lid pos -> if lid == lidV then findNewEps False pos else error $ "" `showFailure` (xhair, lidV) TVector v -> do 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 -- True, because the goal is vague anyway posFromXhair :: MonadClientUI m => m (Either Text Point) posFromXhair = do canAim <- xhairLegalEps case canAim of Right newEps -> do -- Modify @seps@, permanently. modifyClient $ \cli -> cli {seps = newEps} sxhair <- getsSession sxhair mpos <- xhairToPos case mpos of Nothing -> error $ "" `showFailure` sxhair Just pos -> do munit <- projectCheck pos case munit of Nothing -> return $ Right pos Just reqFail -> return $ Left $ showReqFailure reqFail Left cause -> return $ Left cause -- | On top of @permittedProjectClient@, it also checks LOS, legality -- of aiming at the target, projection range. psuitReq :: MonadClientUI m => m (Either Text (ItemFull -> Either ReqFailure (Point, Bool))) psuitReq = do leader <- getLeaderUI b <- getsState $ getActorBody leader lidV <- viewedLevelUI if lidV /= blid b then return $ Left "can't project on remote levels" else do mpos <- posFromXhair p <- permittedProjectClient case mpos of Left err -> return $ Left err Right pos -> return $ Right $ \itemFull -> case p itemFull of Left err -> Left err Right False -> Right (pos, False) Right True -> Right (pos, IK.totalRange (itemKind itemFull) >= chessDist (bpos b) pos) triggerSymbols :: [TriggerItem] -> [Char] triggerSymbols [] = [] triggerSymbols (TriggerItem{tisymbols} : ts) = tisymbols ++ triggerSymbols ts -- * ChooseItemApply chooseItemApplyHuman :: forall m. MonadClientUI m => [TriggerItem] -> m MError chooseItemApplyHuman ts = do leader <- getLeaderUI b <- getsState $ getActorBody leader ar <- getsState $ getActorAspect leader let calmE = calmEnough b ar cLegalRaw = [CGround, CInv, CSha, CEqp] cLegal | calmE = cLegalRaw | otherwise = delete CSha cLegalRaw (verb1, object1) = case ts of [] -> ("apply", "item") tr : _ -> (tiverb tr, tiobject tr) triggerSyms = triggerSymbols ts prompt = makePhrase ["What", object1, "to", verb1] promptGeneric = "What to apply" itemSel <- getsSession sitemSel case itemSel of Just (_, _, True) -> return Nothing Just (iid, fromCStore, False) -> do itemFull <- getsState $ itemToFull iid bag <- getsState $ getBodyStoreBag b fromCStore mp <- permittedApplyClient case iid `EM.lookup` bag of Just kit | either (const False) id (mp itemFull kit) -> return Nothing _ -> do modifySession $ \sess -> sess {sitemSel = Nothing} chooseItemApplyHuman ts Nothing -> do let psuit :: m Suitability psuit = do mp <- permittedApplyClient return $ SuitsSomething $ \itemFull kit -> either (const False) id (mp itemFull kit) && (null triggerSyms || IK.isymbol (itemKind itemFull) `elem` triggerSyms) ggi <- getGroupItem psuit prompt promptGeneric cLegalRaw cLegal case ggi of Right ((iid, _itemFull), (MStore fromCStore, _)) -> do modifySession $ \sess -> sess {sitemSel = Just (iid, fromCStore, False)} return Nothing Left err -> failMsg err _ -> error $ "" `showFailure` ggi permittedApplyClient :: MonadClientUI m => m (ItemFull -> ItemQuant -> Either ReqFailure Bool) permittedApplyClient = do leader <- getLeaderUI b <- getsState $ getActorBody leader ar <- getsState $ getActorAspect leader actorSk <- leaderSkillsClientUI let skill = EM.findWithDefault 0 AbApply actorSk calmE = calmEnough b ar localTime <- getsState $ getLocalTime (blid b) return $ permittedApply localTime skill calmE -- * PickLeader pickLeaderHuman :: MonadClientUI m => Int -> m MError pickLeaderHuman k = do side <- getsClient sside fact <- getsState $ (EM.! side) . sfactionD arena <- getArenaUI sactorUI <- getsSession sactorUI mhero <- getsState $ tryFindHeroK sactorUI side k allA <- getsState $ EM.assocs . sactorD -- not only on one level let allOurs = filter (\(_, body) -> not (bproj body) && bfid body == side) allA allOursUI = map (\(aid, b) -> (aid, b, sactorUI EM.! aid)) allOurs hs = sortBy (comparing keySelected) allOursUI mactor = case drop k hs of [] -> Nothing (aid, b, _) : _ -> Just (aid, b) mchoice = if fhasGender (gplayer fact) then mhero else mactor (autoDun, _) = autoDungeonLevel fact case mchoice of Nothing -> failMsg "no such member of the party" Just (aid, b) | blid b /= arena && autoDun -> failMsg $ showReqFailure NoChangeDunLeader | otherwise -> do void $ pickLeader True aid return Nothing -- * PickLeaderWithPointer pickLeaderWithPointerHuman :: MonadClientUI m => m MError pickLeaderWithPointerHuman = pickLeaderWithPointer -- * MemberCycle -- | Switch current member to the next on the viewed level, if any, wrapping. memberCycleHuman :: MonadClientUI m => m MError memberCycleHuman = memberCycle True -- * MemberBack -- | Switch current member to the previous in the whole dungeon, wrapping. memberBackHuman :: MonadClientUI m => m MError memberBackHuman = memberBack True -- * SelectActor selectActorHuman :: MonadClientUI m => m () selectActorHuman = do leader <- getLeaderUI selectAid leader selectAid :: MonadClientUI m => ActorId -> m () selectAid leader = do bodyUI <- getsSession $ getActorUI leader wasMemeber <- getsSession $ ES.member leader . sselected let upd = if wasMemeber then ES.delete leader -- already selected, deselect instead else ES.insert leader modifySession $ \sess -> sess {sselected = upd $ sselected sess} let subject = partActor bodyUI promptAdd1 $ makeSentence [subject, if wasMemeber then "deselected" else "selected"] -- * SelectNone selectNoneHuman :: MonadClientUI m => m () selectNoneHuman = do side <- getsClient sside lidV <- viewedLevelUI oursIds <- getsState $ fidActorRegularIds side lidV let ours = ES.fromDistinctAscList oursIds oldSel <- getsSession sselected let wasNone = ES.null $ ES.intersection ours oldSel upd = if wasNone then ES.union -- already all deselected; select all instead else ES.difference modifySession $ \sess -> sess {sselected = upd (sselected sess) ours} let subject = "all party members on the level" promptAdd1 $ makeSentence [subject, if wasNone then "selected" else "deselected"] -- * SelectWithPointer selectWithPointerHuman :: MonadClientUI m => m MError selectWithPointerHuman = do lidV <- viewedLevelUI Level{lysize} <- getLevel lidV side <- getsClient sside ours <- getsState $ filter (not . bproj . snd) . actorAssocs (== side) lidV sactorUI <- getsSession sactorUI let oursUI = map (\(aid, b) -> (aid, b, sactorUI EM.! aid)) ours viewed = sortBy (comparing keySelected) oursUI Point{..} <- getsSession spointer -- Select even if no space in status line for the actor's symbol. if | py == lysize + 2 && px == 0 -> selectNoneHuman >> return Nothing | py == lysize + 2 -> case drop (px - 1) viewed of [] -> failMsg "not pointing at an actor" (aid, _, _) : _ -> selectAid aid >> return Nothing | otherwise -> case find (\(_, b) -> bpos b == Point px (py - mapStartY)) ours of Nothing -> failMsg "not pointing at an actor" Just (aid, _) -> selectAid aid >> return Nothing -- * Repeat -- Note that walk followed by repeat should not be equivalent to run, -- because the player can really use a command that does not stop -- at terrain change or when walking over items. repeatHuman :: MonadClientUI m => Int -> m () repeatHuman n = do LastRecord _ seqPrevious k <- getsSession slastRecord let macro = concat $ replicate n $ reverse seqPrevious modifySession $ \sess -> sess {slastPlay = macro ++ slastPlay sess} let slastRecord = LastRecord [] [] (if k == 0 then 0 else maxK) modifySession $ \sess -> sess {slastRecord} maxK :: Int maxK = 100 -- * Record recordHuman :: MonadClientUI m => m () recordHuman = do lastPlayOld <- getsSession slastPlay LastRecord _seqCurrent seqPrevious k <- getsSession slastRecord case k of 0 -> do let slastRecord = LastRecord [] [] maxK modifySession $ \sess -> sess {slastRecord} when (null lastPlayOld) $ -- Don't spam if recording is a part of playing back a macro. promptAdd0 $ "Macro will be recorded for up to" <+> tshow maxK <+> "actions. Stop recording with the same key." _ -> do let slastRecord = LastRecord seqPrevious [] 0 modifySession $ \sess -> sess {slastRecord} when (null lastPlayOld) $ -- Don't spam if recording is a part of playing back a macro. promptAdd0 $ "Macro recording stopped after" <+> tshow (maxK - k - 1) <+> "actions." -- * History historyHuman :: forall m. MonadClientUI m => m () historyHuman = do history <- getsSession shistory arena <- getArenaUI Level{lxsize, lysize} <- getLevel arena localTime <- getsState $ getLocalTime arena global <- getsState stime let rh = renderHistory history turnsGlobal = global `timeFitUp` timeTurn turnsLocal = localTime `timeFitUp` timeTurn msg = makeSentence [ "You survived for" , MU.CarWs turnsGlobal "half-second turn" , "(this level:" , MU.Text (tshow turnsLocal) <> ")" ] kxs = [ (Right sn, (slotPrefix sn, 0, lxsize)) | sn <- take (length rh) intSlots ] promptAdd0 msg okxs <- overlayToSlideshow (lysize + 3) [K.escKM] (rh, kxs) let displayAllHistory = do ekm <- displayChoiceScreen "history" ColorFull True okxs [K.spaceKM, K.escKM] case ekm of Left km | km == K.escKM -> promptAdd0 "Try to survive a few seconds more, if you can." Left km | km == K.spaceKM -> -- click in any unused space promptAdd0 "Steady on." Right SlotChar{..} | slotChar == 'a' -> displayOneReport slotPrefix _ -> error $ "" `showFailure` ekm histBound = lengthHistory history - 1 displayOneReport :: Int -> m () displayOneReport histSlot = do let timeReport = case drop histSlot rh of [] -> error $ "" `showFailure` histSlot tR : _ -> tR ov0 = indentSplitAttrLine lxsize timeReport prompt = makeSentence [ "the", MU.Ordinal $ histSlot + 1 , "record of all history follows" ] keys = [K.spaceKM, K.escKM] ++ [K.upKM | histSlot /= 0] ++ [K.downKM | histSlot /= histBound] promptAdd0 prompt slides <- overlayToSlideshow (lysize + 1) keys (ov0, []) km <- getConfirms ColorFull keys slides case K.key km of K.Space -> displayAllHistory K.Up -> displayOneReport $ histSlot - 1 K.Down -> displayOneReport $ histSlot + 1 K.Esc -> promptAdd0 "Try to learn from your previous mistakes." _ -> error $ "" `showFailure` km displayAllHistory -- * MarkVision markVisionHuman :: MonadClientUI m => m () markVisionHuman = modifySession toggleMarkVision -- * MarkSmell markSmellHuman :: MonadClientUI m => m () markSmellHuman = modifySession toggleMarkSmell -- * MarkSuspect markSuspectHuman :: MonadClientUI m => m () markSuspectHuman = do -- @condBFS@ depends on the setting we change here. invalidateBfsAll modifyClient cycleMarkSuspect -- * PrintScreen printScreenHuman :: MonadClientUI m => m () printScreenHuman = printScreen -- * Cancel -- | End aiming mode, rejecting the current position. cancelHuman :: MonadClientUI m => m () cancelHuman = do saimMode <- getsSession saimMode when (isJust saimMode) $ do clearAimMode promptAdd1 "Target not set." -- * Accept -- | Accept the current x-hair position as target, ending -- aiming mode, if active. acceptHuman :: MonadClientUI m => m () acceptHuman = do endAiming endAimingMsg clearAimMode -- | End aiming mode, accepting the current position. endAiming :: MonadClientUI m => m () endAiming = do leader <- getLeaderUI sxhair <- getsSession sxhair modifyClient $ updateTarget leader $ const $ Just sxhair endAimingMsg :: MonadClientUI m => m () endAimingMsg = do leader <- getLeaderUI (mtargetMsg, _) <- targetDescLeader leader let targetMsg = fromJust mtargetMsg subject <- partAidLeader leader promptAdd1 $ makeSentence [MU.SubjectVerbSg subject "target", MU.Text targetMsg] -- * TgtClear tgtClearHuman :: MonadClientUI m => m () tgtClearHuman = do leader <- getLeaderUI tgt <- getsClient $ getTarget leader case tgt of Just _ -> modifyClient $ updateTarget leader (const Nothing) Nothing -> do clearXhair doLook -- * ItemClear itemClearHuman :: MonadClientUI m => m () itemClearHuman = modifySession $ \sess -> sess {sitemSel = Nothing} -- | Perform look around in the current position of the xhair. -- Does nothing outside aiming mode. doLook :: MonadClientUI m => m () doLook = do saimMode <- getsSession saimMode case saimMode of Nothing -> return () Just aimMode -> do leader <- getLeaderUI let lidV = aimLevelId aimMode xhairPos <- xhairToPos per <- getPerFid lidV b <- getsState $ getActorBody leader let p = fromMaybe (bpos b) xhairPos canSee = ES.member p (totalVisible per) -- Show general info about current position. tileBlurb <- lookAtTile canSee p leader lidV actorsBlurb <- lookAtActors p lidV itemsBlurb <- lookAtItems canSee p leader promptAdd1 $! tileBlurb <+> actorsBlurb <+> itemsBlurb -- * MoveXhair -- | Move the xhair. Assumes aiming mode. moveXhairHuman :: MonadClientUI m => Vector -> Int -> m MError moveXhairHuman dir n = do leader <- getLeaderUI saimMode <- getsSession saimMode let lidV = maybe (error $ "" `showFailure` leader) aimLevelId saimMode Level{lxsize, lysize} <- getLevel lidV lpos <- getsState $ bpos . getActorBody leader sxhair <- getsSession sxhair xhairPos <- xhairToPos let cpos = fromMaybe lpos xhairPos shiftB pos = shiftBounded lxsize lysize pos dir newPos = iterate shiftB cpos !! n if newPos == cpos then failMsg "never mind" else do let tgt = case sxhair of TVector{} -> TVector $ newPos `vectorToFrom` lpos _ -> TPoint TAny lidV newPos modifySession $ \sess -> sess {sxhair = tgt} doLook return Nothing -- * AimTgt -- | Start aiming. aimTgtHuman :: MonadClientUI m => m MError aimTgtHuman = do -- (Re)start aiming at the current level. lidV <- viewedLevelUI modifySession $ \sess -> sess {saimMode = Just $ AimMode lidV} doLook failMsg "aiming started" -- * AimFloor -- | Cycle aiming mode. Do not change position of the xhair, -- switch among things at that position. aimFloorHuman :: MonadClientUI m => m () aimFloorHuman = do lidV <- viewedLevelUI leader <- getLeaderUI lpos <- getsState $ bpos . getActorBody leader xhairPos <- xhairToPos sxhair <- getsSession sxhair saimMode <- getsSession saimMode bsAll <- getsState $ actorAssocs (const True) lidV let xhair = fromMaybe lpos xhairPos tgt = case sxhair of _ | isNothing saimMode -> -- first key press: keep target sxhair TEnemy a True -> TEnemy a False TEnemy{} -> TPoint TAny lidV xhair TPoint{} -> TVector $ xhair `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) == xhairPos) bsAll of Just (im, _) -> TEnemy im True Nothing -> TPoint TAny lidV xhair modifySession $ \sess -> sess {saimMode = Just $ AimMode lidV} modifySession $ \sess -> sess {sxhair = tgt} doLook -- * AimEnemy aimEnemyHuman :: MonadClientUI m => m () aimEnemyHuman = do lidV <- viewedLevelUI leader <- getLeaderUI lpos <- getsState $ bpos . getActorBody leader xhairPos <- xhairToPos sxhair <- getsSession sxhair saimMode <- getsSession saimMode 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 pickUnderXhair = -- switch to the actor under xhair, if any let i = fromMaybe (-1) $ findIndex ((== xhairPos) . Just . bpos . snd) dbs in splitAt i dbs (permitAnyActor, (lt, gt)) = case sxhair of TEnemy a permit | isJust saimMode -> -- 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) TPoint (TEnemyPos _ permit) _ _ -> (permit, pickUnderXhair) _ -> (False, pickUnderXhair) -- the sensible default is only-foes gtlt = gt ++ lt isEnemy b = isFoe side fact (bfid b) && not (bproj b) && bhp b > 0 lf = filter (isEnemy . snd) gtlt tgt | permitAnyActor = case gtlt of (a, _) : _ -> TEnemy a True [] -> sxhair -- no actors in sight, stick to last target | otherwise = case lf of (a, _) : _ -> TEnemy a False [] -> sxhair -- no seen foes in sight, stick to last target -- Register the chosen enemy, to pick another on next invocation. modifySession $ \sess -> sess {saimMode = Just $ AimMode lidV} modifySession $ \sess -> sess {sxhair = tgt} doLook -- * AimItem aimItemHuman :: MonadClientUI m => m () aimItemHuman = do lidV <- viewedLevelUI leader <- getLeaderUI lpos <- getsState $ bpos . getActorBody leader xhairPos <- xhairToPos sxhair <- getsSession sxhair saimMode <- getsSession saimMode bsAll <- getsState $ EM.keys . lfloor . (EM.! lidV) . sdungeon let ordPos p = (chessDist lpos p, p) dbs = sortBy (comparing ordPos) bsAll pickUnderXhair = -- switch to the item under xhair, if any let i = fromMaybe (-1) $ findIndex ((== xhairPos) . Just) dbs in splitAt i dbs (lt, gt) = case sxhair of TPoint _ lid pos | isJust saimMode && lid == lidV -> -- pick next item let i = fromMaybe (-1) $ findIndex (== pos) dbs in splitAt (i + 1) dbs TPoint _ lid pos | lid == lidV -> -- first key press, retarget old item let i = fromMaybe (-1) $ findIndex (== pos) dbs in splitAt i dbs _ -> pickUnderXhair gtlt = gt ++ lt tgt = case gtlt of p : _ -> TPoint TAny lidV p [] -> sxhair -- no items remembered, stick to last target -- Register the chosen enemy, to pick another on next invocation. modifySession $ \sess -> sess {saimMode = Just $ AimMode lidV} modifySession $ \sess -> sess {sxhair = tgt} doLook -- * AimAscend -- | Change the displayed level in aiming mode to (at most) -- k levels shallower. Enters aiming mode, if not already in one. aimAscendHuman :: MonadClientUI m => Int -> m MError aimAscendHuman k = do dungeon <- getsState sdungeon lidV <- viewedLevelUI let up = k > 0 case ascendInBranch dungeon up lidV of [] -> failMsg "no more levels in this direction" _ : _ -> do let ascendOne lid = case ascendInBranch dungeon up lid of [] -> lid nlid : _ -> nlid lidK = iterate ascendOne lidV !! abs k leader <- getLeaderUI lpos <- getsState $ bpos . getActorBody leader xhairPos <- xhairToPos let cpos = fromMaybe lpos xhairPos tgt = TPoint TAny lidK cpos modifySession $ \sess -> sess { saimMode = Just (AimMode lidK) , sxhair = tgt } doLook return Nothing -- * EpsIncr -- | Tweak the @eps@ parameter of the aiming digital line. epsIncrHuman :: MonadClientUI m => Bool -> m () epsIncrHuman b = do saimMode <- getsSession saimMode lidV <- viewedLevelUI modifySession $ \sess -> sess {saimMode = Just $ AimMode lidV} modifyClient $ \cli -> cli {seps = seps cli + if b then 1 else -1} invalidateBfsAll -- actually only paths, but that's cheap enough flashAiming modifySession $ \sess -> sess {saimMode} -- Flash the aiming line and path. flashAiming :: MonadClientUI m => m () flashAiming = do lidV <- viewedLevelUI animate lidV pushAndDelay -- * XhairUnknown xhairUnknownHuman :: MonadClientUI m => m MError xhairUnknownHuman = do leader <- getLeaderUI b <- getsState $ getActorBody leader mpos <- closestUnknown leader case mpos of Nothing -> failMsg "no more unknown spots left" Just p -> do let sxhair = TPoint TUnknown (blid b) p modifySession $ \sess -> sess {sxhair} doLook return Nothing -- * XhairItem xhairItemHuman :: MonadClientUI m => m MError xhairItemHuman = do leader <- getLeaderUI b <- getsState $ getActorBody leader items <- closestItems leader case items of [] -> failMsg "no more items remembered or visible" _ -> do let (_, (p, bag)) = maximumBy (comparing fst) items sxhair = TPoint (TItem bag) (blid b) p modifySession $ \sess -> sess {sxhair} doLook return Nothing -- * XhairStair xhairStairHuman :: MonadClientUI m => Bool -> m MError xhairStairHuman up = do leader <- getLeaderUI b <- getsState $ getActorBody leader stairs <- closestTriggers (if up then ViaStairsUp else ViaStairsDown) leader case stairs of [] -> failMsg $ "no stairs" <+> if up then "up" else "down" _ -> do let (_, (p, (p0, bag))) = maximumBy (comparing fst) stairs sxhair = TPoint (TEmbed bag p0) (blid b) p modifySession $ \sess -> sess {sxhair} doLook return Nothing -- * XhairPointerFloor xhairPointerFloorHuman :: MonadClientUI m => m () xhairPointerFloorHuman = do saimMode <- getsSession saimMode xhairPointerFloor False modifySession $ \sess -> sess {saimMode} xhairPointerFloor :: MonadClientUI m => Bool -> m () xhairPointerFloor verbose = do lidV <- viewedLevelUI Level{lxsize, lysize} <- getLevel lidV Point{..} <- getsSession spointer if px >= 0 && py - mapStartY >= 0 && px < lxsize && py - mapStartY < lysize then do oldXhair <- getsSession sxhair let sxhair = TPoint TAny lidV $ Point px (py - mapStartY) sxhairMoused = sxhair /= oldXhair modifySession $ \sess -> sess { saimMode = Just $ AimMode lidV , sxhair , sxhairMoused } if verbose then doLook else flashAiming else stopPlayBack -- * XhairPointerEnemy xhairPointerEnemyHuman :: MonadClientUI m => m () xhairPointerEnemyHuman = do saimMode <- getsSession saimMode xhairPointerEnemy False modifySession $ \sess -> sess {saimMode} xhairPointerEnemy :: MonadClientUI m => Bool -> m () xhairPointerEnemy verbose = do lidV <- viewedLevelUI Level{lxsize, lysize} <- getLevel lidV Point{..} <- getsSession spointer if px >= 0 && py - mapStartY >= 0 && px < lxsize && py - mapStartY < lysize then do bsAll <- getsState $ actorAssocs (const True) lidV oldXhair <- getsSession sxhair let newPos = Point px (py - mapStartY) sxhair = case find (\(_, m) -> bpos m == newPos) bsAll of Just (im, _) -> TEnemy im True Nothing -> TPoint TAny lidV newPos sxhairMoused = sxhair /= oldXhair modifySession $ \sess -> sess { saimMode = Just $ AimMode lidV , sxhairMoused } modifySession $ \sess -> sess {sxhair} if verbose then doLook else flashAiming else stopPlayBack -- * AimPointerFloor aimPointerFloorHuman :: MonadClientUI m => m () aimPointerFloorHuman = xhairPointerFloor True -- * AimPointerEnemy aimPointerEnemyHuman :: MonadClientUI m => m () aimPointerEnemyHuman = xhairPointerEnemy True LambdaHack-0.8.3.0/Game/LambdaHack/Client/UI/HumanCmd.hs0000644000000000000000000001254313315545734020437 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} -- | Abstract syntax of human player commands. module Game.LambdaHack.Client.UI.HumanCmd ( CmdCategory(..), categoryDescription , CmdArea(..), areaDescription , CmdTriple, HumanCmd(..) , TriggerItem(..), TriggerTile(..) ) where import Prelude () import Game.LambdaHack.Common.Prelude import Control.DeepSeq import Data.Binary import GHC.Generics (Generic) import qualified NLP.Miniutter.English as MU import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.Vector import qualified Game.LambdaHack.Content.TileKind as TK data CmdCategory = CmdMainMenu | CmdDashboard | CmdItemMenu | CmdMove | CmdItem | CmdAim | CmdMeta | CmdMouse | CmdInternal | CmdNoHelp | CmdDebug | CmdMinimal deriving (Show, Read, Eq, Generic) instance NFData CmdCategory instance Binary CmdCategory categoryDescription :: CmdCategory -> Text categoryDescription CmdMainMenu = "Main menu" categoryDescription CmdDashboard = "Dashboard" categoryDescription CmdItemMenu = "Item menu commands" categoryDescription CmdMove = "Terrain exploration and alteration" categoryDescription CmdItem = "Remaining item-related commands" categoryDescription CmdAim = "Aiming" categoryDescription CmdMeta = "Assorted" categoryDescription CmdMouse = "Mouse" categoryDescription CmdInternal = "Internal" categoryDescription CmdNoHelp = "Ignored in help" categoryDescription CmdDebug = "Debug" categoryDescription CmdMinimal = "The minimal command set" -- The constructors are sorted, roughly, wrt inclusion, then top to bottom, -- the left to right. -- | Symbolic representation of areas of the screen used to define the meaning -- of mouse button presses relative to where the mouse points to. data CmdArea = CaMessage | CaMapLeader | CaMapParty | CaMap | CaLevelNumber | CaArenaName | CaPercentSeen | CaXhairDesc | CaSelected | CaCalmGauge | CaHPGauge | CaTargetDesc deriving (Show, Read, Eq, Ord, Generic) instance NFData CmdArea instance Binary CmdArea areaDescription :: CmdArea -> Text areaDescription ca = case ca of CaMessage -> "message line" CaMapLeader -> "leader on map" CaMapParty -> "party on map" CaMap -> "the map area" CaLevelNumber -> "level number" CaArenaName -> "level caption" CaPercentSeen -> "percent seen" CaXhairDesc -> "x-hair info" CaSelected -> "party roster" CaCalmGauge -> "Calm gauge" CaHPGauge -> "HP gauge" CaTargetDesc -> "target info" -- 1234567890123 -- | This triple of command categories, description and the command term itself -- defines the meaning of a human command as entered via a keypress, -- mouse click or chosen from a menu. type CmdTriple = ([CmdCategory], Text, HumanCmd) -- | Abstract syntax of human player commands. data HumanCmd = -- Meta. Macro [String] | ByArea [(CmdArea, HumanCmd)] -- if outside the areas, do nothing | ByAimMode {exploration :: HumanCmd, aiming :: HumanCmd} | ComposeIfLocal HumanCmd HumanCmd | ComposeUnlessError HumanCmd HumanCmd | Compose2ndLocal HumanCmd HumanCmd | LoopOnNothing HumanCmd | ExecuteIfClear HumanCmd -- Global. -- These usually take time. | Wait | Wait10 | MoveDir Vector | RunDir Vector | RunOnceAhead | MoveOnceToXhair | RunOnceToXhair | ContinueToXhair | MoveItem [CStore] CStore (Maybe MU.Part) Bool | Project | Apply | AlterDir [TriggerTile] | AlterWithPointer [TriggerTile] | Help | Hint | ItemMenu | MainMenu | Dashboard -- Below this line, commands do not take time. | GameDifficultyIncr | GameWolfToggle | GameFishToggle | GameScenarioIncr | GameRestart | GameExit | GameSave | Tactic | Automate -- Local. Below this line, commands do not notify the server. | SortSlots | ChooseItem ItemDialogMode | ChooseItemMenu ItemDialogMode | ChooseItemProject [TriggerItem] | ChooseItemApply [TriggerItem] | PickLeader Int | PickLeaderWithPointer | MemberCycle | MemberBack | SelectActor | SelectNone | SelectWithPointer | Repeat Int | Record | History | MarkVision | MarkSmell | MarkSuspect | SettingsMenu | ChallengesMenu | PrintScreen -- These are mostly related to aiming. | Cancel | Accept | TgtClear | ItemClear | MoveXhair Vector Int | AimTgt | AimFloor | AimEnemy | AimItem | AimAscend Int | EpsIncr Bool | XhairUnknown | XhairItem | XhairStair Bool | XhairPointerFloor | XhairPointerEnemy | AimPointerFloor | AimPointerEnemy deriving (Show, Read, Eq, Ord, Generic) instance NFData HumanCmd instance Binary HumanCmd -- | Description of how item manipulation is triggered and communicated -- to the player. data TriggerItem = TriggerItem {tiverb :: MU.Part, tiobject :: MU.Part, tisymbols :: [Char]} deriving (Show, Eq, Ord, Generic) instance Read TriggerItem where readsPrec = error $ "parsing of TriggerItem not implemented" `showFailure` () instance NFData TriggerItem instance Binary TriggerItem -- | Description of how tile altering is triggered and communicated -- to the player. data TriggerTile = TriggerTile {ttverb :: MU.Part, ttobject :: MU.Part, ttfeature :: TK.Feature} deriving (Show, Eq, Ord, Generic) instance Read TriggerTile where readsPrec = error $ "parsing of TriggerTile not implemented" `showFailure` () instance NFData TriggerTile instance Binary TriggerTile LambdaHack-0.8.3.0/Game/LambdaHack/Client/UI/ItemSlot.hs0000644000000000000000000001066413315545734020505 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | Item slots for UI and AI item collections. module Game.LambdaHack.Client.UI.ItemSlot ( SlotChar(..), ItemSlots(..), SingleItemSlots , allSlots, intSlots, slotLabel , assignSlot, partyItemSet, sortSlotMap, mergeItemSlots ) where import Prelude () import Game.LambdaHack.Common.Prelude import Data.Binary import Data.Bits (unsafeShiftL, unsafeShiftR) import Data.Char import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES import Data.Function import Data.Ord (comparing) import qualified Data.Text as T 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 import qualified Game.LambdaHack.Content.ItemKind as IK -- | Slot label. Usually just a character. Sometimes with a numerical prefix. 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) = unsafeShiftL n 8 + ord c + (if isUpper c then 100 else 0) toEnum e = let n = unsafeShiftR e 8 c0 = e - unsafeShiftL n 8 c100 = c0 - if c0 > 150 then 100 else 0 in SlotChar n (chr c100) type SingleItemSlots = EM.EnumMap SlotChar ItemId -- | A collection of mappings from slot labels to item identifiers. newtype ItemSlots = ItemSlots (EM.EnumMap SLore SingleItemSlots) deriving (Show, Binary) allChars :: [Char] allChars = ['a'..'z'] ++ ['A'..'Z'] allSlots :: [SlotChar] allSlots = concatMap (\n -> map (SlotChar n) allChars) [0..] intSlots :: [SlotChar] intSlots = map (flip SlotChar 'a') [0..] slotLabel :: SlotChar -> Text slotLabel x = T.snoc (if slotPrefix x == 0 then T.empty else tshow $ slotPrefix x) (slotChar x) <> ")" -- | Assigns a slot to an item, e.g., for inclusion in the inventory of a hero. assignSlot :: ES.EnumSet ItemId -> SLore -> ItemSlots -> SlotChar assignSlot partySet slore (ItemSlots itemSlots) = head $ freeLowPrefix ++ free where lSlots = itemSlots EM.! slore maxPrefix = case EM.maxViewWithKey lSlots of Just ((lm, _), _) -> slotPrefix lm Nothing -> 0 slotsUpTo k = concatMap (\n -> map (SlotChar n) allChars) [0..k] f l = maybe True (`ES.notMember` partySet) $ EM.lookup l lSlots free = filter f $ slotsUpTo (maxPrefix + 1) -- suffices g l = l {slotPrefix = maxPrefix} `EM.notMember` lSlots freeLowPrefix = filter g free partyItemSet :: SLore -> FactionId -> Maybe Actor -> State -> ES.EnumSet ItemId partyItemSet slore fid mbody s = let onPersons = combinedFromLore slore fid s onGround = maybe EM.empty -- consider floor only under the acting actor (\b -> getFloorBag (blid b) (bpos b) s) mbody in ES.unions $ map EM.keysSet $ onPersons : [onGround | slore == SItem] -- If appearance and aspects the same, keep the order from before sort. compareItemFull :: ItemFull -> ItemFull -> Ordering compareItemFull itemFull1 itemFull2 = let kindAndAppearance ItemFull{itemBase=Item{..}, ..} = ( not itemSuspect, itemKindId, itemDisco , IK.isymbol itemKind, IK.iname itemKind , jflavour, jfid, jlid ) in comparing kindAndAppearance itemFull1 itemFull2 sortSlotMap :: (ItemId -> ItemFull)-> ES.EnumSet ItemId -> SingleItemSlots -> SingleItemSlots sortSlotMap itemToF partySet em = let (nearItems, farItems) = partition (`ES.member` partySet) $ EM.elems em f iid = (iid, itemToF iid) sortItemIds l = map fst $ sortBy (compareItemFull `on` snd) $ map f l in EM.fromDistinctAscList $ zip allSlots $ sortItemIds nearItems ++ sortItemIds farItems mergeItemSlots :: (ItemId -> ItemFull) -> ES.EnumSet ItemId -> [SingleItemSlots] -> SingleItemSlots mergeItemSlots itemToF partySet ems = let renumberSlot n SlotChar{slotPrefix, slotChar} = SlotChar{slotPrefix = slotPrefix + n * 1000000, slotChar} renumberMap n em1 = EM.mapKeys (renumberSlot n) em1 rms = zipWith renumberMap [0..] ems em = EM.unionsWith (\_ _ -> error "mergeItemSlots: duplicate keys") rms in sortSlotMap itemToF partySet em LambdaHack-0.8.3.0/Game/LambdaHack/Client/UI/RunM.hs0000644000000000000000000002706113315545734017625 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.RunM ( continueRun #ifdef EXPOSE_INTERNAL -- * Internal operations , continueRunDir, enterableDir, tryTurning, checkAndRun #endif ) where import Prelude () import Game.LambdaHack.Common.Prelude import qualified Data.EnumMap.Strict as EM import Data.Function import Game.LambdaHack.Client.MonadClient import Game.LambdaHack.Client.Request import Game.LambdaHack.Client.State import Game.LambdaHack.Client.UI.MonadClientUI import Game.LambdaHack.Client.UI.Msg import Game.LambdaHack.Client.UI.Overlay import Game.LambdaHack.Client.UI.SessionUI import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState import Game.LambdaHack.Common.Kind import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.MonadStateRead import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile import Game.LambdaHack.Common.Vector import qualified Game.LambdaHack.Content.TileKind as TK -- | Continue running in the given direction. continueRun :: MonadClientUI m => LevelId -> RunParams -> m (Either Text RequestTimed) continueRun arena paramOld = case paramOld of RunParams{ runMembers = [] , runStopMsg = Just stopMsg } -> return $ Left stopMsg RunParams{ runMembers = [] , runStopMsg = Nothing } -> return $ Left "selected actors no longer there" RunParams{ runLeader , runMembers = r : rs , runInitial , runStopMsg } -> do -- If runInitial and r == runLeader, it means the leader moves -- again, after all other members, in step 0, -- so we call continueRunDir with True to change direction once -- and then unset runInitial. let runInitialNew = runInitial && r /= runLeader paramIni = paramOld {runInitial = runInitialNew} onLevel <- getsState $ memActor r arena onLevelLeader <- getsState $ memActor runLeader arena if | not onLevel -> do let paramNew = paramIni {runMembers = rs } continueRun arena paramNew | not onLevelLeader -> do let paramNew = paramIni {runLeader = r} continueRun arena paramNew | otherwise -> do mdirOrRunStopMsgCurrent <- continueRunDir paramOld let runStopMsgCurrent = either Just (const Nothing) mdirOrRunStopMsgCurrent runStopMsgNew = runStopMsg `mplus` runStopMsgCurrent -- We check @runStopMsgNew@, because even if the current actor -- runs OK, we want to stop soon if some others had to stop. runMembersNew = if isJust runStopMsgNew then rs else rs ++ [r] paramNew = paramIni { runMembers = runMembersNew , runStopMsg = runStopMsgNew } case mdirOrRunStopMsgCurrent of Left _ -> continueRun arena paramNew -- run all others undisturbed; one time Right dir -> do s <- getState modifyClient $ updateLeader r s modifySession $ \sess -> sess {srunning = Just paramNew} return $ Right $ ReqMove dir -- The potential invisible actor is hit. War is started without asking. -- | This function implements the actual logic of running. It checks if we -- have to stop running because something interesting cropped up, -- it ajusts the direction given by the vector if we reached -- a corridor's corner (we never change direction except in corridors) -- and it increments the counter of traversed tiles. -- -- Note that while goto-xhair commands ignore items on the way, -- here we stop wnenever we touch an item. Running is more cautious -- to compensate that the player cannot specify the end-point of running. -- It's also more suited to open, already explored terrain. Goto-xhair -- works better with unknown terrain, e.g., it stops whenever an item -- is spotted, but then ignores the item, leaving it to the player -- to mark the item position as a goal of the next goto. continueRunDir :: MonadClientUI m => RunParams -> m (Either Text Vector) continueRunDir params = case params of RunParams{ runMembers = [] } -> error $ "" `showFailure` params RunParams{ runLeader , runMembers = aid : _ , runInitial } -> do report <- getsSession $ newReport . shistory let boringMsgs = map stringToAL [ "You hear a distant" , "reveals that the" , "Macro will be recorded" , "Macro activated" , "Voicing '" ] boring l = any (`isInfixOf` l) boringMsgs msgShown = isJust $ findInReport (not . boring) report if msgShown then return $ Left "message shown" else do cops@COps{cotile} <- getsState scops rbody <- getsState $ getActorBody runLeader let rposHere = bpos rbody rposLast = fromMaybe (error $ "" `showFailure` (runLeader, rbody)) (boldpos rbody) -- Match run-leader dir, because we want runners to keep formation. dir = rposHere `vectorToFrom` rposLast body <- getsState $ getActorBody aid let lid = blid body lvl <- getLevel lid let posHere = bpos body posThere = posHere `shift` dir actorsThere = posToAidsLvl posThere lvl 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 | enterableDir 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 enterableDir :: COps -> Level -> Point -> Vector -> Bool enterableDir COps{coTileSpeedup} lvl spos dir = Tile.isWalkable coTileSpeedup $ lvl `at` (spos `shift` dir) tryTurning :: MonadClient m => ActorId -> m (Either Text Vector) tryTurning aid = do cops@COps{cotile} <- getsState scops body <- getsState $ getActorBody aid let lid = blid body lvl <- getLevel lid let posHere = bpos body posLast = fromMaybe (error $ "" `showFailure` (aid, body)) (boldpos body) dirLast = posHere `vectorToFrom` posLast let openableDir dir = Tile.isOpenable cotile (lvl `at` (posHere `shift` dir)) dirEnterable dir = enterableDir 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 (enterableDir 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 Text Vector) checkAndRun aid dir = do COps{cotile} <- 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 = posToAidsLvl posThere lvl let posLast = fromMaybe (error $ "" `showFailure` (aid, body)) (boldpos body) dirLast = posHere `vectorToFrom` posLast -- This is supposed to work on unit vectors --- diagonal, as well as, -- vertical and horizontal. anglePos :: Point -> Vector -> RadianAngle -> Point anglePos pos d angle = shift pos (rotate angle d) -- We assume the tiles have not changed since last running step. -- If they did, we don't care --- running should be stopped -- because of the change of nearby tiles then. -- We don't take into account the two tiles at the rear of last -- surroundings, because the actor may have come from there -- (via a diagonal move) and if so, he may be interested in such tiles. -- If he arrived directly from the right or left, he is responsible -- for starting the run further away, if he does not want to ignore -- such tiles as the ones he came from. tileLast = lvl `at` posLast tileHere = lvl `at` posHere tileThere = lvl `at` posThere leftPsLast = map (anglePos posHere dirLast) [pi/2, 3*pi/4] ++ map (anglePos posHere dir) [pi/2, 3*pi/4] rightPsLast = map (anglePos posHere dirLast) [-pi/2, -3*pi/4] ++ map (anglePos posHere dir) [-pi/2, -3*pi/4] leftForwardPosHere = anglePos posHere dir (pi/4) rightForwardPosHere = anglePos posHere dir (-pi/4) leftTilesLast = map (lvl `at`) leftPsLast rightTilesLast = map (lvl `at`) rightPsLast leftForwardTileHere = lvl `at` leftForwardPosHere rightForwardTileHere = lvl `at` rightForwardPosHere featAt = TK.actionFeatures (smarkSuspect > 0) . okind cotile terrainChangeMiddle = 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.8.3.0/Game/LambdaHack/Client/UI/Frame.hs0000644000000000000000000001065613315545734020000 0ustar0000000000000000{-# LANGUAGE RankNTypes, TypeFamilies #-} -- | Screen frames. module Game.LambdaHack.Client.UI.Frame ( FrameST, FrameForall(..), writeLine , SingleFrame(..), Frames , blankSingleFrame, overlayFrame, overlayFrameWithLines #ifdef EXPOSE_INTERNAL -- * Internal operations , truncateAttrLine #endif ) where import Prelude () import Game.LambdaHack.Common.Prelude import Control.Monad.ST.Strict import qualified Data.Vector.Generic as G import qualified Data.Vector.Unboxed as U import qualified Data.Vector.Unboxed.Mutable as VM import Data.Word import Game.LambdaHack.Client.UI.Overlay import qualified Game.LambdaHack.Common.Color as Color import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.Point import qualified Game.LambdaHack.Common.PointArray as PointArray type FrameST s = G.Mutable U.Vector s Word32 -> ST s () -- | Efficiently composable representation of an operation -- on a frame, that is, on a mutable vector. When the composite operation -- is eventually performed, the vector is frozen to become a 'SingleFrame'. newtype FrameForall = FrameForall {unFrameForall :: forall s. FrameST s} -- | Representation of an operation of overwriting a frame with a single line -- at the given row. writeLine :: Int -> AttrLine -> FrameForall {-# INLINE writeLine #-} writeLine offset l = FrameForall $ \v -> do let writeAt _ [] = return () writeAt off (ac32 : rest) = do VM.write v off (Color.attrCharW32 ac32) writeAt (off + 1) rest writeAt offset l -- | An overlay that fits on the screen (or is meant to be truncated on display) -- and is padded to fill the whole screen -- and is displayed as a single game screen frame. -- -- Note that we don't provide a list of color-highlighed positions separately, -- because overlays need to obscure not only map, but the highlights as well. newtype SingleFrame = SingleFrame {singleFrame :: PointArray.Array Color.AttrCharW32} deriving (Eq, Show) -- | Sequences of screen frames, including delays. type Frames = [Maybe FrameForall] blankSingleFrame :: SingleFrame blankSingleFrame = let lxsize = fst normalLevelBound + 1 lysize = snd normalLevelBound + 4 in SingleFrame $ PointArray.replicateA lxsize lysize Color.spaceAttrW32 -- | Truncate the overlay: for each line, if it's too long, it's truncated -- and if there are too many lines, excess is dropped and warning is appended. truncateLines :: Bool -> Overlay -> Overlay truncateLines onBlank l = let lxsize = fst normalLevelBound + 1 lysize = snd normalLevelBound + 1 canvasLength = if onBlank then lysize + 3 else lysize + 1 topLayer = if length l <= canvasLength then l ++ [[] | length l < canvasLength && length l > 3] else take (canvasLength - 1) l ++ [stringToAL "--a portion of the text trimmed--"] f lenPrev lenNext layerLine = truncateAttrLine lxsize layerLine (max lenPrev lenNext) lens = map (min (lxsize - 1) . length) topLayer in zipWith3 f (0 : lens) (drop 1 lens ++ [0]) topLayer -- | Add a space at the message end, for display overlayed over the level map. -- Also trim (do not wrap!) too long lines. truncateAttrLine :: X -> AttrLine -> X -> AttrLine truncateAttrLine w xs lenMax = case compare w (length xs) of LT -> let discarded = drop w xs in if all (== Color.spaceAttrW32) discarded then take w xs else take (w - 1) xs ++ [Color.attrChar2ToW32 Color.BrBlack '$'] EQ -> xs GT -> let xsSpace = if | null xs -> xs | last xs == Color.spaceAttrW32 -> xs ++ [Color.spaceAttrW32] | otherwise -> xs ++ [Color.spaceAttrW32, Color.spaceAttrW32] whiteN = max (40 - length xsSpace) (1 + lenMax - length xsSpace) in xsSpace ++ replicate whiteN Color.spaceAttrW32 -- | Overlays either the game map only or the whole empty screen frame. -- We assume the lines of the overlay are not too long nor too many. overlayFrame :: IntOverlay -> FrameForall -> FrameForall overlayFrame ov ff = FrameForall $ \v -> do unFrameForall ff v mapM_ (\(offset, l) -> unFrameForall (writeLine offset l) v) ov overlayFrameWithLines :: Bool -> Overlay -> FrameForall -> FrameForall overlayFrameWithLines onBlank l msf = let lxsize = fst normalLevelBound + 1 ov = map (\(y, al) -> (y * lxsize, al)) $ zip [0..] $ truncateLines onBlank l in overlayFrame ov msf LambdaHack-0.8.3.0/Game/LambdaHack/Client/UI/Msg.hs0000644000000000000000000001531313315545734017467 0ustar0000000000000000{-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving #-} -- | Game messages displayed on top of the screen for the player to read -- and then saved to player history. module Game.LambdaHack.Client.UI.Msg ( -- * Msg Msg, toMsg, toPrompt -- * Report , Report, nullReport, consReport, renderReport, findInReport -- * History , History, newReport, emptyHistory, addToReport, archiveReport, lengthHistory , renderHistory #ifdef EXPOSE_INTERNAL -- * Internal operations , UAttrLine, RepMsgN, uToAttrLine, attrLineToU , emptyReport, snocReport, renderRepetition, scrapRepetition, renderTimeReport #endif ) where import Prelude () import Game.LambdaHack.Common.Prelude import Data.Binary import Data.Vector.Binary () import qualified Data.Vector.Unboxed as U import Data.Word (Word32) import GHC.Generics (Generic) import Game.LambdaHack.Client.UI.Overlay import qualified Game.LambdaHack.Common.Color as Color import qualified Game.LambdaHack.Common.RingBuffer as RB import Game.LambdaHack.Common.Time -- * UAttrLine type UAttrLine = U.Vector Word32 uToAttrLine :: UAttrLine -> AttrLine uToAttrLine v = map Color.AttrCharW32 $ U.toList v attrLineToU :: AttrLine -> UAttrLine attrLineToU l = U.fromList $ map Color.attrCharW32 l -- * Msg -- | The type of a single game message. data Msg = Msg { msgLine :: AttrLine -- ^ the colours and characters of the message , msgHist :: Bool -- ^ whether message should be recorded in history } deriving (Show, Eq, Generic) instance Binary Msg toMsg :: AttrLine -> Msg toMsg l = Msg { msgLine = l , msgHist = True } toPrompt :: AttrLine -> Msg toPrompt l = Msg { msgLine = l , msgHist = False } -- * Report data RepMsgN = RepMsgN {repMsg :: Msg, _repN :: Int} deriving (Show, Generic) instance Binary RepMsgN -- | The set of messages, with repetitions, to show at the screen at once. newtype Report = Report [RepMsgN] 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 -- | Add a message to the end of the report. snocReport :: Report -> Msg -> Int -> Report snocReport (Report !r) y n = if null $ msgLine y then Report r else Report $ RepMsgN y n : r -- | Add a message to the start of report. consReport :: Msg -> Report -> Report consReport Msg{msgLine=[]} rep = rep consReport y (Report r) = Report $ r ++ [RepMsgN y 1] -- | Render a report as a (possibly very long) 'AttrLine'. renderReport :: Report -> AttrLine renderReport (Report []) = [] renderReport (Report (x : xs)) = renderReport (Report xs) <+:> renderRepetition x renderRepetition :: RepMsgN -> AttrLine renderRepetition (RepMsgN s 0) = msgLine s renderRepetition (RepMsgN s 1) = msgLine s renderRepetition (RepMsgN s n) = msgLine s ++ stringToAL ("") findInReport :: (AttrLine -> Bool) -> Report -> Maybe Msg findInReport f (Report xns) = find (f . msgLine) $ map repMsg xns -- * History -- | The history of reports. This is a ring buffer of the given length -- containing old archived history and two most recent reports stored -- separately. data History = History { newReport :: Report , newTime :: Time , oldReport :: Report , oldTime :: Time , archivedHistory :: RB.RingBuffer UAttrLine } deriving (Show, Generic) instance Binary History -- | Empty history of the given maximal length. emptyHistory :: Int -> History emptyHistory size = History emptyReport timeZero emptyReport timeZero $ RB.empty size U.empty scrapRepetition :: History -> Maybe History scrapRepetition History{ newReport = Report newMsgs , oldReport = Report oldMsgs , .. } = case newMsgs of -- We take into account only first message of the new report, -- because others were deduplicated as they were added. -- We keep the message in the new report, because it should not -- vanish from the screen. In this way the message may be passed -- along many reports and, e.g., reduce disturbance over many turns, -- as for "X hears something". RepMsgN s1 n1 : rest1 -> let f (RepMsgN s2 _) = s1 == s2 in case break f rest1 of (_, []) -> case break f oldMsgs of (_, []) -> Nothing (noDup, RepMsgN _ n2 : rest2) -> -- We keep the occurence of the message in the new report only. let newReport = Report $ RepMsgN s1 (n1 + n2) : rest1 oldReport = Report $ noDup ++ rest2 in Just History{..} (noDup, RepMsgN _ n2 : rest2) -> -- We keep the older (and so, oldest) occurence of the message, -- to avoid visual disruption by moving the message around. let newReport = Report $ noDup ++ RepMsgN s1 (n1 + n2) : rest2 oldReport = Report oldMsgs in Just History{..} _ -> Nothing -- empty new report -- | Add a message to the new report of history, eliminating a possible -- duplicate and noting its existence in the result. addToReport :: History -> Msg -> Int -> (History, Bool) addToReport History{..} msg n = let newH = History{newReport = snocReport newReport msg n, ..} in case scrapRepetition newH of Just scrappedH -> (scrappedH, True) Nothing -> (newH, False) -- | Archive old report to history, filtering out prompts. -- Set up new report with a new timestamp. archiveReport :: History -> Time -> History archiveReport History{newReport=Report newMsgs, ..} !newT = let f (RepMsgN _ n) = n > 0 newReportNon0 = Report $ filter f newMsgs in if nullReport newReportNon0 then -- Drop empty new report. Start a new one with the new timestamp. History emptyReport newT oldReport oldTime archivedHistory else let lU = map attrLineToU $ renderTimeReport oldTime oldReport in History emptyReport newT newReportNon0 newTime $ foldl' (flip RB.cons) archivedHistory (reverse lU) renderTimeReport :: Time -> Report -> [AttrLine] renderTimeReport !t (Report r') = let turns = t `timeFitUp` timeTurn rep = Report $ filter (msgHist . repMsg) r' in if nullReport rep then [] else [stringToAL (show turns ++ ": ") ++ renderReport rep] lengthHistory :: History -> Int lengthHistory History{oldReport, archivedHistory} = RB.length archivedHistory + if nullReport oldReport then 0 else 1 -- | Render history as many lines of text. New report is not rendered. -- It's expected to be empty when history is shown. renderHistory :: History -> [AttrLine] renderHistory History{..} = map uToAttrLine (RB.toList archivedHistory) ++ renderTimeReport oldTime oldReport LambdaHack-0.8.3.0/Game/LambdaHack/Client/UI/SlideshowM.hs0000644000000000000000000002532013315545734021016 0ustar0000000000000000-- | Monadic operations on slideshows and related data. module Game.LambdaHack.Client.UI.SlideshowM ( overlayToSlideshow, reportToSlideshow, reportToSlideshowKeep , displaySpaceEsc, displayMore, displayMoreKeep, displayYesNo, getConfirms , displayChoiceScreen ) where import Prelude () import Data.Either import qualified Data.Map.Strict as M import Game.LambdaHack.Common.Prelude import Game.LambdaHack.Client.UI.FrameM import Game.LambdaHack.Client.UI.ItemSlot import qualified Game.LambdaHack.Client.UI.Key as K import Game.LambdaHack.Client.UI.MonadClientUI import Game.LambdaHack.Client.UI.MsgM import Game.LambdaHack.Client.UI.Overlay import Game.LambdaHack.Client.UI.SessionUI import Game.LambdaHack.Client.UI.Slideshow import qualified Game.LambdaHack.Common.Color as Color import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.MonadStateRead import Game.LambdaHack.Common.Point -- | Add current report to the overlay, split the result and produce, -- possibly, many slides. overlayToSlideshow :: MonadClientUI m => Y -> [K.KM] -> OKX -> m Slideshow overlayToSlideshow y keys okx = do lidV <- viewedLevelUI Level{lxsize} <- getLevel lidV report <- getReportUI recordHistory -- report will be shown soon, remove it to history return $! splitOverlay lxsize y report keys okx -- | Split current report into a slideshow. reportToSlideshow :: MonadClientUI m => [K.KM] -> m Slideshow reportToSlideshow keys = do lidV <- viewedLevelUI Level{lysize} <- getLevel lidV overlayToSlideshow (lysize + 1) keys ([], []) -- | Split current report into a slideshow. Keep report unchanged. reportToSlideshowKeep :: MonadClientUI m => [K.KM] -> m Slideshow reportToSlideshowKeep keys = do lidV <- viewedLevelUI Level{lxsize, lysize} <- getLevel lidV report <- getReportUI -- Don't do @recordHistory@; the message is important, but related -- to the messages that come after, so should be shown together. return $! splitOverlay lxsize (lysize + 1) report keys ([], []) -- | Display a message. Return value indicates if the player wants to continue. -- Feature: if many pages, only the last SPACE exits (but first ESC). displaySpaceEsc :: MonadClientUI m => ColorMode -> Text -> m Bool displaySpaceEsc dm prompt = do promptAdd0 prompt -- Two frames drawn total (unless @prompt@ very long). slides <- reportToSlideshow [K.spaceKM, K.escKM] km <- getConfirms dm [K.spaceKM, K.escKM] slides return $! km == K.spaceKM -- | Display a message. Ignore keypresses. -- Feature: if many pages, only the last SPACE exits (but first ESC). displayMore :: MonadClientUI m => ColorMode -> Text -> m () displayMore dm prompt = do promptAdd0 prompt slides <- reportToSlideshow [K.spaceKM] void $ getConfirms dm [K.spaceKM, K.escKM] slides displayMoreKeep :: MonadClientUI m => ColorMode -> Text -> m () displayMoreKeep dm prompt = do promptAdd0 prompt slides <- reportToSlideshowKeep [K.spaceKM] void $ getConfirms dm [K.spaceKM, K.escKM] slides -- | Print a yes/no question and return the player's answer. Use black -- and white colours to turn player's attention to the choice. displayYesNo :: MonadClientUI m => ColorMode -> Text -> m Bool displayYesNo dm prompt = do promptAdd0 prompt let yn = map K.mkChar ['y', 'n'] slides <- reportToSlideshow yn km <- getConfirms dm (K.escKM : yn) slides return $! km == K.mkChar 'y' getConfirms :: MonadClientUI m => ColorMode -> [K.KM] -> Slideshow -> m K.KM getConfirms dm extraKeys slides = do ekm <- displayChoiceScreen "" dm False slides extraKeys return $! either id (error $ "" `showFailure` ekm) ekm -- | Display a, potentially, multi-screen menu and return the chosen -- key or item slot label (and the index in the whole menu so that the cursor -- can again be placed at that spot next time menu is displayed). -- -- This function is the only source of menus and so, effectively, UI modes. displayChoiceScreen :: forall m . MonadClientUI m => String -> ColorMode -> Bool -> Slideshow -> [K.KM] -> m (Either K.KM SlotChar) displayChoiceScreen menuName dm sfBlank frsX extraKeys = do let frs = slideshow frsX keys = concatMap (concatMap (either id (const []) . fst) . snd) frs ++ extraKeys !_A = assert (K.escKM `elem` extraKeys) () navigationKeys = [ K.leftButtonReleaseKM, K.rightButtonReleaseKM , K.returnKM, K.spaceKM , K.upKM, K.leftKM, K.downKM, K.rightKM , K.pgupKM, K.pgdnKM, K.wheelNorthKM, K.wheelSouthKM , K.homeKM, K.endKM ] legalKeys = keys ++ navigationKeys -- The arguments go from first menu line and menu page to the last, -- in order. Their indexing is from 0. We select the nearest item -- with the index equal or less to the pointer. findKYX :: Int -> [OKX] -> Maybe (OKX, KYX, Int) findKYX _ [] = Nothing findKYX pointer (okx@(_, kyxs) : frs2) = case drop pointer kyxs of [] -> -- not enough menu items on this page case findKYX (pointer - length kyxs) frs2 of Nothing -> -- no more menu items in later pages case reverse kyxs of [] -> Nothing kyx : _ -> Just (okx, kyx, length kyxs - 1) res -> res kyx : _ -> Just (okx, kyx, pointer) maxIx = length (concatMap snd frs) - 1 allOKX = concatMap snd frs initIx = case findIndex (isRight . fst) allOKX of Just p -> p _ -> length allOKX clearIx = if initIx > maxIx then 0 else initIx page :: Int -> m (Either K.KM SlotChar, Int) page pointer = assert (pointer >= 0) $ case findKYX pointer frs of Nothing -> error $ "no menu keys" `showFailure` frs Just ((ov, kyxs), (ekm, (y, x1, x2)), ixOnPage) -> do let highableAttrs = [Color.defAttr, Color.defAttr {Color.fg = Color.BrBlack}] highAttr x | Color.acAttr x `notElem` highableAttrs = x highAttr x = x {Color.acAttr = (Color.acAttr x) {Color.fg = Color.BrWhite}} drawHighlight xs = let (xs1, xsRest) = splitAt x1 xs (xs2, xs3) = splitAt (x2 - x1) xsRest highW32 = Color.attrCharToW32 . highAttr . Color.attrCharFromW32 in xs1 ++ map highW32 xs2 ++ xs3 ov1 = updateLines y drawHighlight ov ignoreKey = page pointer pageLen = length kyxs xix (_, (_, x1', _)) = x1' == x1 firstRowOfNextPage = pointer + pageLen - ixOnPage restOKX = drop firstRowOfNextPage allOKX firstItemOfNextPage = case findIndex (isRight . fst) restOKX of Just p -> p + firstRowOfNextPage _ -> firstRowOfNextPage interpretKey :: K.KM -> m (Either K.KM SlotChar, Int) interpretKey ikm = case K.key ikm of K.Return | ekm /= Left [K.returnKM] -> case ekm of Left (km : _) -> interpretKey km Left [] -> error $ "" `showFailure` ikm Right c -> return (Right c, pointer) K.LeftButtonRelease -> do Point{..} <- getsSession spointer let onChoice (_, (cy, cx1, cx2)) = cy == py && cx1 <= px && cx2 > px case find onChoice kyxs of Nothing | ikm `elem` keys -> return (Left ikm, pointer) Nothing -> if K.spaceKM `elem` keys then return (Left K.spaceKM, pointer) else ignoreKey Just (ckm, _) -> case ckm of Left (km : _) -> if K.key km == K.Return && km `elem` keys then return (Left km, pointer) else interpretKey km Left [] -> error $ "" `showFailure` ikm Right c -> return (Right c, pointer) K.RightButtonRelease -> if | ikm `elem` keys -> return (Left ikm, pointer) | K.escKM `elem` keys -> return (Left K.escKM, pointer) | otherwise -> ignoreKey K.Space | firstItemOfNextPage <= maxIx -> page firstItemOfNextPage K.Unknown "SAFE_SPACE" -> if firstItemOfNextPage <= maxIx then page firstItemOfNextPage else page clearIx _ | ikm `elem` keys -> return (Left ikm, pointer) K.Up -> case findIndex xix $ reverse $ take ixOnPage kyxs of Nothing -> interpretKey ikm{K.key=K.Left} Just ix -> page (max 0 (pointer - ix - 1)) K.Left -> if pointer == 0 then page maxIx else page (max 0 (pointer - 1)) K.Down -> case findIndex xix $ drop (ixOnPage + 1) kyxs of Nothing -> interpretKey ikm{K.key=K.Right} Just ix -> page (pointer + ix + 1) K.Right -> if pointer == maxIx then page 0 else page (min maxIx (pointer + 1)) K.Home -> page clearIx K.End -> page maxIx _ | K.key ikm `elem` [K.PgUp, K.WheelNorth] -> page (max 0 (pointer - ixOnPage - 1)) _ | K.key ikm `elem` [K.PgDn, K.WheelSouth] -> page (min maxIx firstItemOfNextPage) K.Space -> if pointer == maxIx then page clearIx else page maxIx _ -> error $ "unknown key" `showFailure` ikm pkm <- promptGetKey dm ov1 sfBlank legalKeys interpretKey pkm menuIxMap <- getsSession smenuIxMap -- Beware, values in @menuIxMap@ may be negative (meaning: a key, not slot). let menuIx | menuName == "" = clearIx | otherwise = maybe clearIx (+ initIx) (M.lookup menuName menuIxMap) -- this may be negative, from different context (km, pointer) <- if null frs then return (Left K.escKM, menuIx) else page $ max clearIx $ min maxIx menuIx -- the saved index could be from different context unless (menuName == "") $ modifySession $ \sess -> sess {smenuIxMap = M.insert menuName (pointer - initIx) menuIxMap} assert (either (`elem` keys) (const True) km) $ return km LambdaHack-0.8.3.0/Game/LambdaHack/Client/UI/KeyBindings.hs0000644000000000000000000003021213315545734021142 0ustar0000000000000000{-# LANGUAGE TupleSections #-} -- | Verifying, aggregating and displaying binding of keys to commands. module Game.LambdaHack.Client.UI.KeyBindings ( Binding(..), stdBinding, keyHelp, okxsN ) where import Prelude () import Game.LambdaHack.Common.Prelude import qualified Data.Map.Strict as M import qualified Data.Text as T import Game.LambdaHack.Client.UI.Content.KeyKind import Game.LambdaHack.Client.UI.HumanCmd import Game.LambdaHack.Client.UI.ItemSlot import qualified Game.LambdaHack.Client.UI.Key as K import Game.LambdaHack.Client.UI.Overlay import Game.LambdaHack.Client.UI.Slideshow import Game.LambdaHack.Client.UI.UIOptions import qualified Game.LambdaHack.Common.Color as Color import Game.LambdaHack.Common.Kind import Game.LambdaHack.Content.RuleKind -- | Bindings and other information about human player commands. data Binding = Binding { bcmdMap :: M.Map K.KM CmdTriple -- ^ binding of keys to commands , bcmdList :: [(K.KM, CmdTriple)] -- ^ the properly ordered list -- of commands for the help menu , brevMap :: M.Map HumanCmd [K.KM] -- ^ and from commands to their keys } -- | Create binding of keys to movement and other standard commands, -- as well as commands defined in the config file. stdBinding :: KeyKind -- ^ default key bindings from the content -> UIOptions -- ^ UI client options -> Binding -- ^ concrete binding stdBinding (KeyKind copsClient) UIOptions{uCommands, uVi, uLaptop} = let waitTriple = ([CmdMove], "", Wait) wait10Triple = ([CmdMove], "", Wait10) moveXhairOr n cmd v = ByAimMode { exploration = cmd v , aiming = MoveXhair v n } bcmdList = (if uVi then filter (\(k, _) -> k `notElem` [K.mkKM "period", K.mkKM "C-period"]) else id) copsClient ++ uCommands ++ [ (K.mkKM "KP_Begin", waitTriple) , (K.mkKM "C-KP_Begin", wait10Triple) , (K.mkKM "KP_5", waitTriple) , (K.mkKM "C-KP_5", wait10Triple) ] ++ (if | uVi -> [ (K.mkKM "period", waitTriple) , (K.mkKM "C-period", wait10Triple) ] | uLaptop -> [ (K.mkKM "i", waitTriple) , (K.mkKM "C-i", wait10Triple) , (K.mkKM "I", waitTriple) ] | otherwise -> []) ++ K.moveBinding uVi uLaptop (\v -> ([CmdMove], "", moveXhairOr 1 MoveDir v)) (\v -> ([CmdMove], "", moveXhairOr 10 RunDir v)) rejectRepetitions t1 t2 = error $ "duplicate key" `showFailure` (t1, t2) in Binding { bcmdMap = M.fromListWith rejectRepetitions [ (k, triple) | (k, triple@(cats, _, _)) <- bcmdList , all (`notElem` [CmdMainMenu]) cats ] , bcmdList , brevMap = M.fromListWith (flip (++)) $ concat [ [(cmd, [k])] | (k, (cats, _desc, cmd)) <- bcmdList , all (`notElem` [CmdMainMenu, CmdDebug, CmdNoHelp]) cats ] } -- | Produce a set of help/menu screens from the key bindings. keyHelp :: COps -> Binding -> Int -> [(Text, OKX)] keyHelp cops keyb@Binding{..} offset = assert (offset > 0) $ let stdRuleset = getStdRuleset cops introBlurb = "" : map T.pack (rintroScreen stdRuleset) ++ [ "" , "Press SPACE for help or ESC to see the map again." ] movBlurb = [ "" , "Walk throughout a level with mouse or numeric keypad (left diagram below)" , "or its compact laptop replacement (middle) or the Vi text editor keys (right," , "enabled in config.ui.ini). Run, until disturbed, by adding Shift or Control." , "Go-to with LMB (left mouse button). Run collectively with RMB." , "" , " 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, the same keys (and mouse) move the x-hair (aiming crosshair)." , "Press 'KP_5' ('5' on keypad, or 'i' or '.') to wait, bracing for impact," , "which reduces any damage taken and prevents displacement by foes. Press" , "'C-KP_5' (the same key with Control) to wait 0.1 of a turn, without bracing." , "You displace enemies by running into them with Shift/Control or RMB. Search," , "open, descend and attack by bumping into walls, doors, stairs and enemies." , "The best item to attack with is automatically chosen from among weapons" , "in your personal equipment and your body parts." , "" , "Press SPACE or scroll the mouse wheel to see the minimal command set." ] minimalBlurb = [ "The following commands, joined with the basic set above, let you accomplish" , "anything in the game, though not necessarily with the fewest keystrokes." , "You can also play the game exclusively with a mouse, or both mouse and" , "keyboard. See the ending help screens for mouse commands. Lastly, you can" , "select a command with arrows or mouse directly from the help screen" , "or the dashboard and execute it on the spot." , "" ] casualEnding = [ "" , "Press SPACE to see the detailed descriptions of all commands." ] categoryEnding = [ "" , "Press SPACE to see the next page of command descriptions." ] lastCategoryEnding = [ "" , "Press SPACE to see mouse command descriptions." ] mouseBasicsBlurb = [ "Screen area and UI mode (aiming/exploration) determine mouse click effects." , "Here is an overview of effects of each button over most of the game map area." , "The list includes not only left and right buttons, but also the optional" , "middle mouse button (MMB) and even the mouse wheel, which is normally used" , "over menus, to page-scroll them." , "For mice without RMB, one can use C-LMB (Control key and left mouse button)." , "" ] mouseBasicsEnding = [ "" , "Press SPACE to see mouse commands in aiming mode." ] mouseAimingModeEnding = [ "" , "Press SPACE to see mouse commands in explorations mode." ] lastHelpEnding = [ "" , "For more playing instructions see file PLAYING.md." , "Press PGUP or scroll the mouse wheel to return to previous pages" , "and press SPACE or ESC to see the map again." ] keyL = 12 pickLeaderDescription = [ fmt keyL "0, 1 ... 6" "pick a particular actor as the new leader" ] casualDescription = "Minimal cheat sheet for casual play" fmt n k h = " " <> T.justifyLeft n ' ' k <+> h fmts s = " " <> s introText = map fmts introBlurb movText = map fmts movBlurb minimalText = map fmts minimalBlurb casualEnd = map fmts casualEnding categoryEnd = map fmts categoryEnding lastCategoryEnd = map fmts lastCategoryEnding mouseBasicsText = map fmts mouseBasicsBlurb mouseBasicsEnd = map fmts mouseBasicsEnding mouseAimingModeEnd = map fmts mouseAimingModeEnding lastHelpEnd = map fmts lastHelpEnding keyCaptionN n = fmt n "keys" "command" keyCaption = keyCaptionN keyL okxs = okxsN keyb offset keyL (const False) True keyM = 13 keyB = 31 truncatem b = if T.length b > keyB then T.take (keyB - 1) b <> "$" else b fmm a b c = fmt keyM a $ fmt keyB (truncatem b) (" " <> truncatem c) areaCaption = fmm "area" "LMB (left mouse button)" "RMB (right mouse button)" keySel :: ((HumanCmd, HumanCmd) -> HumanCmd) -> K.KM -> [(CmdArea, Either K.KM SlotChar, Text)] keySel sel key = let cmd = case M.lookup key bcmdMap of Just (_, _, cmd2) -> cmd2 Nothing -> error $ "" `showFailure` key caCmds = case cmd of ByAimMode{..} -> case sel (exploration, aiming) of ByArea l -> sort l _ -> error $ "" `showFailure` cmd _ -> error $ "" `showFailure` cmd caMakeChoice (ca, cmd2) = let (km, desc) = case M.lookup cmd2 brevMap of Just ks -> let descOfKM km2 = case M.lookup km2 bcmdMap of Just (_, "", _) -> Nothing Just (_, desc2, _) -> Just (km2, desc2) Nothing -> error $ "" `showFailure` km2 in case mapMaybe descOfKM ks of [] -> error $ "" `showFailure` (ks, cmd2) kmdesc3 : _ -> kmdesc3 Nothing -> (key, "(not described:" <+> tshow cmd2 <> ")") in (ca, Left km, desc) in map caMakeChoice caCmds okm :: ((HumanCmd, HumanCmd) -> HumanCmd) -> K.KM -> K.KM -> [Text] -> [Text] -> OKX okm sel key1 key2 header footer = let kst1 = keySel sel key1 kst2 = keySel sel key2 f (ca1, Left km1, _) (ca2, Left km2, _) y = assert (ca1 == ca2) [ (Left [km1], (y, keyM + 3, keyB + keyM + 3)) , (Left [km2], (y, keyB + keyM + 5, 2 * keyB + keyM + 5)) ] f c d e = error $ "" `showFailure` (c, d, e) kxs = concat $ zipWith3 f kst1 kst2 [offset + length header..] render (ca1, _, desc1) (_, _, desc2) = fmm (areaDescription ca1) desc1 desc2 menu = zipWith render kst1 kst2 in (map textToAL $ "" : header ++ menu ++ footer, kxs) in [ ( rtitle stdRuleset <+> "- backstory" , (map textToAL introText, []) ) , ( casualDescription <+> "(1/2)." , (map textToAL movText, []) ) , ( casualDescription <+> "(2/2)." , okxs CmdMinimal (minimalText ++ [keyCaption]) casualEnd ) , ( "All terrain exploration and alteration commands." , okxs CmdMove [keyCaption] (pickLeaderDescription ++ categoryEnd) ) , ( categoryDescription CmdItemMenu <> "." , okxs CmdItemMenu [keyCaption] categoryEnd ) , ( categoryDescription CmdItem <> "." , okxs CmdItem [keyCaption] categoryEnd ) , ( categoryDescription CmdAim <> "." , okxs CmdAim [keyCaption] categoryEnd ) , ( categoryDescription CmdMeta <> "." , okxs CmdMeta [keyCaption] lastCategoryEnd ) , ( "Mouse overview." , let (ls, _) = okxs CmdMouse (mouseBasicsText ++ [keyCaption]) mouseBasicsEnd in (ls, []) ) -- don't capture mouse wheel, etc. , ( "Mouse in aiming mode." , okm snd K.leftButtonReleaseKM K.rightButtonReleaseKM [areaCaption] mouseAimingModeEnd ) , ( "Mouse in exploration mode." , okm fst K.leftButtonReleaseKM K.rightButtonReleaseKM [areaCaption] lastHelpEnd ) ] -- | Turn the specified portion of bindings into a menu. okxsN :: Binding -> Int -> Int -> (HumanCmd -> Bool) -> Bool -> CmdCategory -> [Text] -> [Text] -> OKX okxsN Binding{..} offset n greyedOut showManyKeys cat header footer = let fmt k h = " " <> T.justifyLeft n ' ' k <+> h coImage :: HumanCmd -> [K.KM] coImage cmd = M.findWithDefault (error $ "" `showFailure` cmd) cmd brevMap disp = T.intercalate " or " . map (T.pack . K.showKM) keyKnown km = case K.key km of K.Unknown{} -> False _ -> True keys :: [(Either [K.KM] SlotChar, (Bool, Text))] keys = [ (Left kmsRes, (greyedOut cmd, fmt keyNames desc)) | (_, (cats, desc, cmd)) <- bcmdList , let kms = coImage cmd knownKeys = filter keyKnown kms keyNames = disp $ (if showManyKeys then id else take 1) knownKeys kmsRes = if desc == "" then knownKeys else kms , cat `elem` cats , desc /= "" || CmdInternal `elem` cats] f (ks, (_, tkey)) y = (ks, (y, 1, T.length tkey)) kxs = zipWith f keys [offset + length header..] ts = map (False,) ("" : header) ++ map snd keys ++ map (False,) footer greyToAL (b, t) = if b then fgToAL Color.BrBlack t else textToAL t in (map greyToAL ts, kxs) LambdaHack-0.8.3.0/Game/LambdaHack/Client/UI/HandleHumanGlobalM.hs0000644000000000000000000017146313315545734022374 0ustar0000000000000000-- | Semantics of "Game.LambdaHack.Client.UI.HumanCmd" -- client commands that return server requests. -- A couple of them do not take time, the rest does. -- Here prompts and menus are displayed, but any feedback resulting -- from the commands (e.g., from inventory manipulation) is generated later on, -- by the server, for all clients that witness the results of the commands. module Game.LambdaHack.Client.UI.HandleHumanGlobalM ( -- * Meta commands byAreaHuman, byAimModeHuman , composeIfLocalHuman, composeUnlessErrorHuman, compose2ndLocalHuman , loopOnNothingHuman, executeIfClearHuman -- * Global commands that usually take time , waitHuman, waitHuman10, moveRunHuman , runOnceAheadHuman, moveOnceToXhairHuman , runOnceToXhairHuman, continueToXhairHuman , moveItemHuman, projectHuman, applyHuman , alterDirHuman, alterWithPointerHuman , helpHuman, hintHuman, dashboardHuman, itemMenuHuman, chooseItemMenuHuman , mainMenuHuman, settingsMenuHuman, challengesMenuHuman , gameScenarioIncr, gameDifficultyIncr, gameWolfToggle, gameFishToggle -- * Global commands that never take time , gameRestartHuman, gameExitHuman, gameSaveHuman , tacticHuman, automateHuman #ifdef EXPOSE_INTERNAL -- * Internal operations , areaToRectangles, meleeAid, displaceAid, moveSearchAlter, goToXhair , multiActorGoTo, moveOrSelectItem, selectItemsToMove, moveItems, projectItem , applyItem, alterTile, alterTileAtPos, verifyAlters, verifyEscape, guessAlter , artWithVersion, generateMenu, nxtGameMode #endif ) where import Prelude () import Game.LambdaHack.Common.Prelude -- Cabal import qualified Paths_LambdaHack as Self (version) import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES import qualified Data.Map.Strict as M import qualified Data.Text as T import Data.Version import qualified NLP.Miniutter.English as MU import Game.LambdaHack.Client.Bfs import Game.LambdaHack.Client.BfsM import Game.LambdaHack.Client.CommonM import Game.LambdaHack.Client.MonadClient import Game.LambdaHack.Client.Request import Game.LambdaHack.Client.State import Game.LambdaHack.Client.UI.ActorUI import Game.LambdaHack.Client.UI.FrameM import Game.LambdaHack.Client.UI.Frontend (frontendName) import Game.LambdaHack.Client.UI.HandleHelperM import Game.LambdaHack.Client.UI.HandleHumanLocalM import Game.LambdaHack.Client.UI.HumanCmd import Game.LambdaHack.Client.UI.InventoryM import Game.LambdaHack.Client.UI.ItemDescription import qualified Game.LambdaHack.Client.UI.Key as K import Game.LambdaHack.Client.UI.KeyBindings import Game.LambdaHack.Client.UI.MonadClientUI import Game.LambdaHack.Client.UI.Msg import Game.LambdaHack.Client.UI.MsgM import Game.LambdaHack.Client.UI.Overlay import Game.LambdaHack.Client.UI.RunM import Game.LambdaHack.Client.UI.SessionUI import Game.LambdaHack.Client.UI.Slideshow import Game.LambdaHack.Client.UI.SlideshowM import Game.LambdaHack.Client.UI.UIOptions import Game.LambdaHack.Common.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.ItemAspect as IA import Game.LambdaHack.Common.Kind import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.MonadStateRead import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.Random import Game.LambdaHack.Common.ReqFailure 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.RuleKind import Game.LambdaHack.Content.TileKind (TileKind) import qualified Game.LambdaHack.Content.TileKind as TK -- * ByArea -- | Pick command depending on area the mouse pointer is in. -- The first matching area is chosen. If none match, only interrupt. byAreaHuman :: MonadClientUI m => (HumanCmd -> m (Either MError ReqUI)) -> [(CmdArea, HumanCmd)] -> m (Either MError ReqUI) byAreaHuman cmdAction l = do pointer <- getsSession spointer let pointerInArea a = do rs <- areaToRectangles a return $! any (inside pointer) rs cmds <- filterM (pointerInArea . fst) l case cmds of [] -> do stopPlayBack return $ Left Nothing (_, cmd) : _ -> cmdAction cmd -- Many values here are shared with "Game.LambdaHack.Client.UI.DrawM". areaToRectangles :: MonadClientUI m => CmdArea -> m [(X, Y, X, Y)] areaToRectangles ca = case ca of CaMessage -> return [(0, 0, fst normalLevelBound, 0)] CaMapLeader -> do -- takes preference over @CaMapParty@ and @CaMap@ leader <- getLeaderUI b <- getsState $ getActorBody leader let Point{..} = bpos b return [(px, mapStartY + py, px, mapStartY + py)] CaMapParty -> do -- takes preference over @CaMap@ lidV <- viewedLevelUI side <- getsClient sside ours <- getsState $ filter (not . bproj) . map snd . actorAssocs (== side) lidV let rectFromB Point{..} = (px, mapStartY + py, px, mapStartY + py) return $! map (rectFromB . bpos) ours CaMap -> return [( 0, mapStartY, fst normalLevelBound, mapStartY + snd normalLevelBound )] CaLevelNumber -> let y = snd normalLevelBound + 2 in return [(0, y, 1, y)] CaArenaName -> let y = snd normalLevelBound + 2 x = fst normalLevelBound `div` 2 - 11 in return [(3, y, x, y)] CaPercentSeen -> let y = snd normalLevelBound + 2 x = fst normalLevelBound `div` 2 in return [(x - 9, y, x, y)] CaXhairDesc -> let y = snd normalLevelBound + 2 x = fst normalLevelBound `div` 2 + 2 in return [(x, y, fst normalLevelBound, y)] CaSelected -> let y = snd normalLevelBound + 3 x = fst normalLevelBound `div` 2 in return [(0, y, x - 24, y)] CaCalmGauge -> let y = snd normalLevelBound + 3 x = fst normalLevelBound `div` 2 in return [(x - 22, y, x - 11, y)] CaHPGauge -> let y = snd normalLevelBound + 3 x = fst normalLevelBound `div` 2 in return [(x - 9, y, x, y)] CaTargetDesc -> let y = snd normalLevelBound + 3 x = fst normalLevelBound `div` 2 + 2 in return [(x, y, fst normalLevelBound, y)] -- * ByAimMode byAimModeHuman :: MonadClientUI m => m (Either MError ReqUI) -> m (Either MError ReqUI) -> m (Either MError ReqUI) byAimModeHuman cmdNotAimingM cmdAimingM = do aimMode <- getsSession saimMode if isNothing aimMode then cmdNotAimingM else cmdAimingM -- * ComposeIfLocal composeIfLocalHuman :: MonadClientUI m => m (Either MError ReqUI) -> m (Either MError ReqUI) -> m (Either MError ReqUI) composeIfLocalHuman c1 c2 = do slideOrCmd1 <- c1 case slideOrCmd1 of Left merr1 -> do slideOrCmd2 <- c2 case slideOrCmd2 of Left merr2 -> return $ Left $ mergeMError merr1 merr2 _ -> return slideOrCmd2 _ -> return slideOrCmd1 -- * ComposeUnlessError composeUnlessErrorHuman :: MonadClientUI m => m (Either MError ReqUI) -> m (Either MError ReqUI) -> m (Either MError ReqUI) composeUnlessErrorHuman c1 c2 = do slideOrCmd1 <- c1 case slideOrCmd1 of Left Nothing -> c2 _ -> return slideOrCmd1 -- * Compose2ndLocal compose2ndLocalHuman :: MonadClientUI m => m (Either MError ReqUI) -> m (Either MError ReqUI) -> m (Either MError ReqUI) compose2ndLocalHuman c1 c2 = do slideOrCmd1 <- c1 case slideOrCmd1 of Left merr1 -> do slideOrCmd2 <- c2 case slideOrCmd2 of Left merr2 -> return $ Left $ mergeMError merr1 merr2 _ -> return slideOrCmd1 -- ignore second request, keep effect req -> do void c2 -- ignore second request, keep effect return req -- * LoopOnNothing loopOnNothingHuman :: MonadClientUI m => m (Either MError ReqUI) -> m (Either MError ReqUI) loopOnNothingHuman cmd = do res <- cmd case res of Left Nothing -> loopOnNothingHuman cmd _ -> return res -- * ExecuteIfClear executeIfClearHuman :: MonadClientUI m => m (Either MError ReqUI) -> m (Either MError ReqUI) executeIfClearHuman c1 = do sreportNull <- getsSession sreportNull if sreportNull then c1 else return $ Left Nothing -- * Wait -- | Leader waits a turn (and blocks, etc.). waitHuman :: MonadClientUI m => m (FailOrCmd RequestTimed) waitHuman = do actorSk <- leaderSkillsClientUI if EM.findWithDefault 0 AbWait actorSk > 0 then do modifySession $ \sess -> sess {swaitTimes = abs (swaitTimes sess) + 1} return $ Right ReqWait else failSer WaitUnskilled -- * Wait10 -- | Leader waits a 1/10th of a turn (and doesn't block, etc.). waitHuman10 :: MonadClientUI m => m (FailOrCmd RequestTimed) waitHuman10 = do actorSk <- leaderSkillsClientUI if EM.findWithDefault 0 AbWait actorSk > 0 then do modifySession $ \sess -> sess {swaitTimes = abs (swaitTimes sess) + 1} return $ Right ReqWait10 else failSer WaitUnskilled -- * MoveDir and RunDir moveRunHuman :: MonadClientUI m => Bool -> Bool -> Bool -> Bool -> Vector -> m (FailOrCmd RequestTimed) moveRunHuman initialStep finalGoal run runAhead dir = do actorSk <- leaderSkillsClientUI 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 <- getsSession sselected let runMembers = if runAhead || noRunWithMulti fact then [leader] else ES.toList (ES.delete leader sel) ++ [leader] runParams = RunParams { runLeader = leader , runMembers , runInitial = True , runStopMsg = Nothing , runWaiting = 0 } macroRun25 = ["C-comma", "C-V"] when (initialStep && run) $ do modifySession $ \cli -> cli {srunning = Just runParams} when runAhead $ modifySession $ \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). let tpos = bpos sb `shift` dir -- We start by checking actors at the target position, -- which gives a partial information (actors can be invisible), -- as opposed to accessibility (and items) which are always accurate -- (tiles can't be invisible). tgts <- getsState $ posToAssocs tpos arena case tgts of [] -> do -- move or search or alter runStopOrCmd <- moveSearchAlter dir case runStopOrCmd of Left stopMsg -> return $ Left 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 && EM.findWithDefault 0 AbDisplace actorSk > 0 -> -- No @stopPlayBack@: initial displace is benign enough. -- Displacing requires accessibility, but it's checked later on. displaceAid target _ : _ : _ | run && initialStep && EM.findWithDefault 0 AbDisplace actorSk > 0 -> do let !_A = assert (all (bproj . snd) tgts) () failSer DisplaceProjectiles (target, tb) : _ | not run && initialStep && finalGoal && bfid tb == bfid sb && not (bproj tb) -> do stopPlayBack -- don't ever auto-repeat leader choice -- We always see actors from our own faction. -- Select one of adjacent actors by bumping into him. Takes no time. success <- pickLeader True target let !_A = assert (success `blame` "bump self" `swith` (leader, target, tb)) () failWith "by bumping" (target, tb) : _ | not run && initialStep && finalGoal && (bfid tb /= bfid sb || bproj tb) && EM.findWithDefault 0 AbMelee actorSk > 0 -> do stopPlayBack -- don't ever auto-repeat melee -- No problem if there are many projectiles at the spot. We just -- attack the first one. meleeAid target _ : _ -> failWith "actor in the way" -- | Actor attacks an enemy actor or his own projectile. meleeAid :: MonadClientUI m => ActorId -> m (FailOrCmd RequestTimed) 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 = do -- Set personal target to the enemy position, -- to easily him with a ranged attack when he flees. let f (Just (TEnemy _ b)) = Just $ TEnemy target b f (Just (TPoint (TEnemyPos _ b) _ _)) = Just $ TEnemy target b f _ = Just $ TEnemy target False modifyClient $ updateTarget leader f return $ Right wp res | bproj tb || isFoe (bfid sb) sfact (bfid tb) = returnCmd | isFriend (bfid sb) sfact (bfid tb) = do let !_A = assert (bfid sb /= bfid tb) () go1 <- displayYesNo ColorBW "You are bound by an alliance. Really attack?" if not go1 then failWith "attack canceled" else returnCmd | otherwise = do go2 <- displayYesNo ColorBW "This attack will start a war. Are you sure?" if not go2 then failWith "attack canceled" else returnCmd res -- Seeing the actor prevents altering a tile under it, but that -- does not limit the player, he just doesn't waste a turn -- on a failed altering. -- | Actor swaps position with another. displaceAid :: MonadClientUI m => ActorId -> m (FailOrCmd RequestTimed) displaceAid target = do COps{coTileSpeedup} <- getsState scops leader <- getLeaderUI sb <- getsState $ getActorBody leader tb <- getsState $ getActorBody target tfact <- getsState $ (EM.! bfid tb) . sfactionD actorMaxSk <- maxActorSkillsClient target disp <- getsState $ dispEnemy leader target actorMaxSk let immobile = EM.findWithDefault 0 AbMove actorMaxSk <= 0 tpos = bpos tb adj = checkAdjacent sb tb atWar = isFoe (bfid tb) tfact (bfid sb) if | not adj -> failSer DisplaceDistant | not (bproj tb) && atWar && actorDying tb -> failSer DisplaceDying | not (bproj tb) && atWar && braced tb -> failSer DisplaceBraced | not (bproj tb) && atWar && immobile -> failSer DisplaceImmobile | not disp && atWar -> failSer DisplaceSupported | otherwise -> do let lid = blid sb lvl <- getLevel lid -- Displacing requires full access. if Tile.isWalkable coTileSpeedup $ lvl `at` tpos then case posToAidsLvl tpos lvl of [] -> error $ "" `showFailure` (leader, sb, target, tb) [_] -> return $ Right $ ReqDisplace target _ -> failSer DisplaceProjectiles else failSer DisplaceAccess -- | Leader moves or searches or alters. No visible actor at the position. moveSearchAlter :: MonadClientUI m => Vector -> m (FailOrCmd RequestTimed) moveSearchAlter dir = do COps{coTileSpeedup} <- getsState scops actorSk <- leaderSkillsClientUI leader <- getLeaderUI sb <- getsState $ getActorBody leader ar <- getsState $ getActorAspect leader let calmE = calmEnough sb ar moveSkill = EM.findWithDefault 0 AbMove actorSk alterSkill = EM.findWithDefault 0 AbAlter actorSk applySkill = EM.findWithDefault 0 AbApply actorSk spos = bpos sb -- source position tpos = spos `shift` dir -- target position itemToF <- getsState $ flip itemToFull localTime <- getsState $ getLocalTime (blid sb) embeds <- getsState $ getEmbedBag (blid sb) tpos lvl <- getLevel $ blid sb let t = lvl `at` tpos alterMinSkill = Tile.alterMinSkill coTileSpeedup t canApplyEmbeds = any canApplyEmbed $ EM.assocs embeds canApplyEmbed (iid, kit) = let itemFull = itemToF iid legal = permittedApply localTime applySkill calmE itemFull kit -- Let even completely unskilled actors trigger basic embeds. in either (const False) (const True) legal modifiable = Tile.isDoor coTileSpeedup t || Tile.isChangable coTileSpeedup t || Tile.isSuspect coTileSpeedup t runStopOrCmd <- -- Movement requires full access. if | Tile.isWalkable coTileSpeedup t && moveSkill > 0 -> -- A potential invisible actor is hit. War started without asking. return $ Right $ ReqMove dir -- No free access or skill, so search and/or alter the tile. | not (modifiable || canApplyEmbeds) -> failWith "never mind" -- misclick? walkable but no move skill? related to AlterNothing | alterSkill <= 1 -> failSer AlterUnskilled | not (Tile.isSuspect coTileSpeedup t) && alterSkill < alterMinSkill -> failSer AlterUnwalked | EM.member tpos $ lfloor lvl -> failSer AlterBlockItem | not $ null $ posToAidsLvl tpos lvl -> failSer AlterBlockActor | otherwise -> do -- promising verAlters <- verifyAlters (blid sb) tpos case verAlters of Right() -> return $ Right $ ReqAlter tpos Left err -> return $ Left err -- We don't use ReqMove, because we don't hit invisible actors, -- e.g., hidden in a wall. If server performed an attack for free -- on the invisible actor anyway, the player (or AI) -- would be tempted to repeatedly hit random walls -- in hopes of killing a monster 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. return $! runStopOrCmd -- * RunOnceAhead runOnceAheadHuman :: MonadClientUI m => m (Either MError RequestTimed) runOnceAheadHuman = do side <- getsClient sside fact <- getsState $ (EM.! side) . sfactionD leader <- getLeaderUI UIOptions{uRunStopMsgs} <- getsSession sUIOptions keyPressed <- anyKeyPressed srunning <- getsSession srunning -- When running, stop if disturbed. If not running, stop at once. case srunning of Nothing -> do stopPlayBack return $ Left Nothing Just RunParams{runMembers} | noRunWithMulti fact && runMembers /= [leader] -> do stopPlayBack if uRunStopMsgs then weaveJust <$> failWith "run stop: automatic leader change" else return $ Left Nothing Just _runParams | keyPressed -> do discardPressedKey stopPlayBack if uRunStopMsgs then weaveJust <$> failWith "run stop: key pressed" else weaveJust <$> failWith "interrupted" Just runParams -> do arena <- getArenaUI runOutcome <- continueRun arena runParams case runOutcome of Left stopMsg -> do stopPlayBack if uRunStopMsgs then weaveJust <$> failWith ("run stop:" <+> stopMsg) else return $ Left Nothing Right runCmd -> return $ Right runCmd -- * MoveOnceToXhair moveOnceToXhairHuman :: MonadClientUI m => m (FailOrCmd RequestTimed) moveOnceToXhairHuman = goToXhair True False goToXhair :: MonadClientUI m => Bool -> Bool -> m (FailOrCmd RequestTimed) goToXhair initialStep run = do aimMode <- getsSession saimMode -- Movement is legal only outside aiming mode. if isJust aimMode then failWith "cannot move in aiming mode" else do leader <- getLeaderUI b <- getsState $ getActorBody leader xhairPos <- xhairToPos case xhairPos of Nothing -> failWith "crosshair position invalid" Just c | c == bpos b -> do actorSk <- leaderSkillsClientUI if initialStep && EM.findWithDefault 0 AbWait actorSk > 0 then return $ Right $ ReqWait else failWith "position reached" Just c -> do running <- getsSession srunning case running of -- Don't use running params from previous run or goto-xhair. Just paramOld | not initialStep -> do arena <- getArenaUI runOutcome <- multiActorGoTo arena c paramOld case runOutcome of Left stopMsg -> return $ Left stopMsg Right (finalGoal, dir) -> moveRunHuman initialStep finalGoal run False dir _ -> do let !_A = assert (initialStep || not run) () (bfs, mpath) <- getCacheBfsAndPath leader c xhairMoused <- getsSession sxhairMoused case mpath of _ | xhairMoused && isNothing (accessBfs bfs c) -> failWith "no route to crosshair" _ | initialStep && adjacent (bpos b) c -> do let dir = towards (bpos b) c moveRunHuman initialStep True run False dir NoPath -> failWith "no route to crosshair" AndPath{pathList=[]} -> failWith "almost there" AndPath{pathList = p1 : _} -> do let finalGoal = p1 == c dir = towards (bpos b) p1 moveRunHuman initialStep finalGoal run False dir multiActorGoTo :: MonadClientUI m => LevelId -> Point -> RunParams -> m (FailOrCmd (Bool, Vector)) multiActorGoTo arena c paramOld = case paramOld of RunParams{runMembers = []} -> failWith "selected actors no longer there" RunParams{runMembers = r : rs, runWaiting} -> do onLevel <- getsState $ memActor r arena 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 (bfs, mpath) <- getCacheBfsAndPath r c xhairMoused <- getsSession sxhairMoused case mpath of _ | xhairMoused && isNothing (accessBfs bfs c) -> failWith "no route to crosshair" NoPath -> failWith "no route to crosshair" AndPath{pathList=[]} -> failWith "almost there" AndPath{pathList = p1 : _} -> do let finalGoal = p1 == c dir = towards (bpos b) p1 tgts <- getsState $ posToAids p1 arena case tgts of [] -> do modifySession $ \sess -> sess {srunning = Just paramNew} return $ Right (finalGoal, dir) [target] | target `elem` rs || runWaiting <= length rs -> -- Let r wait until all others move. Mark it in runWaiting -- to avoid cycles. When all wait for each other, fail. multiActorGoTo arena c paramNew{runWaiting=runWaiting + 1} _ -> failWith "actor in the way" -- * RunOnceToXhair runOnceToXhairHuman :: MonadClientUI m => m (FailOrCmd RequestTimed) runOnceToXhairHuman = goToXhair True True -- * ContinueToXhair continueToXhairHuman :: MonadClientUI m => m (FailOrCmd RequestTimed) continueToXhairHuman = goToXhair False False{-irrelevant-} -- * MoveItem moveItemHuman :: forall m. MonadClientUI m => [CStore] -> CStore -> Maybe MU.Part -> Bool -> m (FailOrCmd RequestTimed) moveItemHuman cLegalRaw destCStore mverb auto = do actorSk <- leaderSkillsClientUI if EM.findWithDefault 0 AbMoveItem actorSk > 0 then moveOrSelectItem cLegalRaw destCStore mverb auto else failSer MoveItemUnskilled -- This cannot be structured as projecting or applying, with @ByItemMode@ -- and @ChooseItemToMove@, because at least in case of grabbing items, -- more than one item is chosen, which doesn't fit @sitemSel@. Separating -- grabbing of multiple items as a distinct command is too high a price. moveOrSelectItem :: forall m. MonadClientUI m => [CStore] -> CStore -> Maybe MU.Part -> Bool -> m (FailOrCmd RequestTimed) moveOrSelectItem cLegalRaw destCStore mverb auto = do itemSel <- getsSession sitemSel modifySession $ \sess -> sess {sitemSel = Nothing} -- prevent surprise case itemSel of Just (iid, fromCStore, _) | fromCStore /= destCStore && fromCStore `elem` cLegalRaw -> do leader <- getLeaderUI b <- getsState $ getActorBody leader bag <- getsState $ getBodyStoreBag b fromCStore case iid `EM.lookup` bag of Nothing -> -- the case of old selection or selection from another actor moveItemHuman cLegalRaw destCStore mverb auto Just (k, it) -> assert (k > 0) $ do itemFull <- getsState $ itemToFull iid let eqpFree = eqpFreeN b kToPick | destCStore == CEqp = min eqpFree k | otherwise = k if kToPick == 0 then failWith "no more items can be equipped" else do socK <- pickNumber (not auto) kToPick case socK of Left Nothing -> moveItemHuman cLegalRaw destCStore mverb auto Left (Just err) -> return $ Left err Right kChosen -> let is = ( fromCStore , [(iid, (itemFull, (kChosen, take kChosen it)))] ) in moveItems cLegalRaw is destCStore _ -> do mis <- selectItemsToMove cLegalRaw destCStore mverb auto case mis of Left err -> return $ Left err Right (fromCStore, [(iid, _)]) | cLegalRaw /= [CGround] -> do modifySession $ \sess -> sess {sitemSel = Just (iid, fromCStore, False)} moveItemHuman cLegalRaw destCStore mverb auto Right is -> moveItems cLegalRaw is destCStore selectItemsToMove :: forall m. MonadClientUI m => [CStore] -> CStore -> Maybe MU.Part -> Bool -> m (FailOrCmd (CStore, [(ItemId, ItemFullKit)])) selectItemsToMove 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 -- 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) ar <- getsState $ getActorAspect leader lastItemMove <- getsSession slastItemMove let calmE = calmEnough b ar cLegalE | calmE = cLegalRaw | destCStore == CSha = [] | otherwise = delete CSha cLegalRaw cLegal = case lastItemMove of Just (lastFrom, lastDest) | lastDest == destCStore && lastFrom `elem` cLegalE -> lastFrom : delete lastFrom cLegalE _ -> cLegalE prompt = makePhrase ["What to", verb] promptEqp = makePhrase ["What consumable to", verb] (promptGeneric, psuit) = -- We prune item list only for eqp, because other stores don't have -- so clear cut heuristics. So when picking up a stash, either grab -- it to auto-store things, or equip first using the pruning -- and then pack/stash the rest selectively or en masse. if destCStore == CEqp && cLegalRaw /= [CGround] then (promptEqp, return $ SuitsSomething $ \itemFull _kit -> IK.goesIntoEqp $ itemKind itemFull) else (prompt, return SuitsEverything) ggi <- getFull psuit (\_ _ _ cCur -> prompt <+> ppItemDialogModeFrom cCur) (\_ _ _ cCur -> promptGeneric <+> ppItemDialogModeFrom cCur) cLegalRaw cLegal (not auto) True case ggi of Right (l, (MStore fromCStore, _)) -> do modifySession $ \sess -> sess {slastItemMove = Just (fromCStore, destCStore)} return $ Right (fromCStore, l) Left err -> failWith err _ -> error $ "" `showFailure` ggi moveItems :: forall m. MonadClientUI m => [CStore] -> (CStore, [(ItemId, ItemFullKit)]) -> CStore -> m (FailOrCmd RequestTimed) moveItems cLegalRaw (fromCStore, l) destCStore = do leader <- getLeaderUI b <- getsState $ getActorBody leader ar <- getsState $ getActorAspect leader discoBenefit <- getsClient sdiscoBenefit let calmE = calmEnough b ar ret4 :: [(ItemId, ItemFullKit)] -> Int -> [(ItemId, Int, CStore, CStore)] -> m (FailOrCmd [(ItemId, Int, CStore, CStore)]) ret4 [] _ acc = return $ Right $ reverse acc ret4 ((iid, (itemFull, (itemK, _))) : rest) oldN acc = do let k = itemK !_A = assert (k > 0) () retRec toCStore = let n = oldN + if toCStore == CEqp then k else 0 in ret4 rest n ((iid, k, fromCStore, toCStore) : acc) inEqp = benInEqp $ discoBenefit EM.! iid if cLegalRaw == [CGround] -- normal pickup then case destCStore of -- @CEqp@ is the implicit default; refine: CEqp | calmE && IK.goesIntoSha (itemKind itemFull) -> retRec CSha CEqp | inEqp && 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. let fullWarn = if eqpOverfull b (oldN + 1) then EqpOverfull else EqpStackFull msgAdd $ "Warning:" <+> showReqFailure fullWarn <> "." retRec $ if calmE then CSha else CInv CEqp | inEqp -> retRec CEqp CEqp -> retRec CInv _ -> retRec destCStore else case destCStore of -- player forces store, so @inEqp@ ignored 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 if not calmE && CSha `elem` [fromCStore, destCStore] then failSer ItemNotCalm else do l4 <- ret4 l 0 [] return $! case l4 of Left err -> Left err Right [] -> error $ "" `showFailure` l Right lr -> Right $ ReqMoveItems lr -- * Project projectHuman :: MonadClientUI m => m (FailOrCmd RequestTimed) projectHuman = do actorSk <- leaderSkillsClientUI if EM.findWithDefault 0 AbProject actorSk <= 0 then -- detailed check later failSer ProjectUnskilled else do itemSel <- getsSession sitemSel case itemSel of Just (iid, fromCStore, _) -> do leader <- getLeaderUI b <- getsState $ getActorBody leader bag <- getsState $ getBodyStoreBag b fromCStore case iid `EM.lookup` bag of Nothing -> failWith "no item to fling" Just _kit -> do itemFull <- getsState $ itemToFull iid let i = (fromCStore, (iid, itemFull)) projectItem i Nothing -> failWith "no item to fling" projectItem :: MonadClientUI m => (CStore, (ItemId, ItemFull)) -> m (FailOrCmd RequestTimed) projectItem (fromCStore, (iid, itemFull)) = do leader <- getLeaderUI b <- getsState $ getActorBody leader ar <- getsState $ getActorAspect leader let calmE = calmEnough b ar if not calmE && fromCStore == CSha then failSer ItemNotCalm else do mpsuitReq <- psuitReq case mpsuitReq of Left err -> failWith err Right psuitReqFun -> case psuitReqFun itemFull of Left reqFail -> failSer reqFail Right (pos, _) -> do -- Set personal target to the aim position, to easily repeat. mposTgt <- leaderTgtToPos unless (Just pos == mposTgt) $ do sxhair <- getsSession sxhair modifyClient $ updateTarget leader (const $ Just sxhair) -- Project. eps <- getsClient seps return $ Right $ ReqProject pos eps iid fromCStore -- * Apply applyHuman :: MonadClientUI m => m (FailOrCmd RequestTimed) applyHuman = do actorSk <- leaderSkillsClientUI if EM.findWithDefault 0 AbApply actorSk <= 0 then -- detailed check later failSer ApplyUnskilled else do itemSel <- getsSession sitemSel case itemSel of Just (iid, fromCStore, _) -> do leader <- getLeaderUI b <- getsState $ getActorBody leader bag <- getsState $ getBodyStoreBag b fromCStore case iid `EM.lookup` bag of Nothing -> failWith "no item to apply" Just kit -> do itemFull <- getsState $ itemToFull iid applyItem (fromCStore, (iid, (itemFull, kit))) Nothing -> failWith "no item to apply" applyItem :: MonadClientUI m => (CStore, (ItemId, ItemFullKit)) -> m (FailOrCmd RequestTimed) applyItem (fromCStore, (iid, (itemFull, kit))) = do leader <- getLeaderUI b <- getsState $ getActorBody leader ar <- getsState $ getActorAspect leader let calmE = calmEnough b ar if not calmE && fromCStore == CSha then failSer ItemNotCalm else do p <- permittedApplyClient case p itemFull kit of Left reqFail -> failSer reqFail Right _ -> return $ Right $ ReqApply iid fromCStore -- * AlterDir -- | Ask for a direction and alter a tile in the specified way, if possible. alterDirHuman :: MonadClientUI m => [TriggerTile] -> m (FailOrCmd RequestTimed) alterDirHuman ts = do UIOptions{uVi, uLaptop} <- getsSession sUIOptions let verb1 = case ts of [] -> "alter" tr : _ -> ttverb tr keys = K.escKM : K.leftButtonReleaseKM : map (K.KM K.NoModifier) (K.dirAllKey uVi uLaptop) prompt = makePhrase ["Where to", verb1 <> "? [movement key] [pointer]"] promptAdd0 prompt slides <- reportToSlideshow [K.escKM] km <- getConfirms ColorFull keys slides case K.key km of K.LeftButtonRelease -> do leader <- getLeaderUI b <- getsState $ getActorBody leader Point x y <- getsSession spointer let dir = Point x (y - mapStartY) `vectorToFrom` bpos b if isUnit dir then alterTile ts dir else failWith "never mind" _ -> case K.handleDir uVi uLaptop km of Nothing -> failWith "never mind" Just dir -> alterTile ts dir -- | Try to alter a tile using a feature in the given direction. alterTile :: MonadClientUI m => [TriggerTile] -> Vector -> m (FailOrCmd RequestTimed) alterTile ts dir = do leader <- getLeaderUI b <- getsState $ getActorBody leader let tpos = bpos b `shift` dir pText = compassText dir alterTileAtPos ts tpos pText -- | Try to alter a tile using a feature at the given position. -- -- We don't check if the tile is interesting, e.g., if any embedded -- item can be triggered, because the player explicitely requested -- the action. Consequently, even if all embedded items are recharching, -- the time will be wasted and the server will describe the failure in detail. alterTileAtPos :: MonadClientUI m => [TriggerTile] -> Point -> Text -> m (FailOrCmd RequestTimed) alterTileAtPos ts tpos pText = do cops@COps{cotile, coTileSpeedup} <- getsState scops leader <- getLeaderUI b <- getsState $ getActorBody leader actorSk <- leaderSkillsClientUI lvl <- getLevel $ blid b embeds <- getsState $ getEmbedBag (blid b) tpos let alterSkill = EM.findWithDefault 0 AbAlter actorSk t = lvl `at` tpos alterMinSkill = Tile.alterMinSkill coTileSpeedup t hasFeat TriggerTile{ttfeature} = Tile.hasFeature cotile ttfeature t modifiable = Tile.isDoor coTileSpeedup t || Tile.isChangable coTileSpeedup t || Tile.isSuspect coTileSpeedup t case filter hasFeat ts of [] | not $ null ts -> failWith $ guessAlter cops ts t _ | not modifiable && EM.null embeds -> failSer AlterNothing _ | chessDist tpos (bpos b) > 1 -> failSer AlterDistant _ | alterSkill <= 1 -> failSer AlterUnskilled _ | not (Tile.isSuspect coTileSpeedup t) && alterSkill < alterMinSkill -> failSer AlterUnwalked trs -> if EM.notMember tpos $ lfloor lvl then if null (posToAidsLvl tpos lvl) then do let v = case trs of [] -> "alter" tr : _ -> ttverb tr verAlters <- verifyAlters (blid b) tpos case verAlters of Right() -> do let msg = makeSentence ["you", v, MU.Text pText] msgAdd msg return $ Right $ ReqAlter tpos Left err -> return $ Left err else failSer AlterBlockActor else failSer AlterBlockItem -- | Verify important effects, such as fleeing the dungeon. -- -- This is contrived for now, the embedded items are not analyzed, -- but only recognized by name. verifyAlters :: MonadClientUI m => LevelId -> Point -> m (FailOrCmd ()) verifyAlters lid p = do COps{coTileSpeedup} <- getsState scops lvl <- getLevel lid let t = lvl `at` p bag <- getsState $ getEmbedBag lid p getKind <- getsState $ flip getIidKind let ks = map getKind $ EM.keys bag if | any (any IK.isEffEscape . IK.ieffects) ks -> verifyEscape | null ks && not (Tile.isDoor coTileSpeedup t || Tile.isChangable coTileSpeedup t || Tile.isSuspect coTileSpeedup t) -> failWith "never mind" | otherwise -> return $ Right () verifyEscape :: MonadClientUI m => m (FailOrCmd ()) verifyEscape = do 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 side if total == 0 then do -- The player can back off at this step. We don't insist, because -- possibly the score formula doesn't reward treasure, or possibly -- the dungeon definition rules out treasure, or this particular -- dungeon has none by a fluke in dungeon generation. go1 <- displaySpaceEsc ColorBW "Afraid of the challenge? Leaving so soon and without any treasure?" if not go1 then failWith "here's your chance!" else return $ Right () else return $ Right () -- | Guess and report why the bump command failed. guessAlter :: COps -> [TriggerTile] -> ContentId TileKind -> Text guessAlter COps{cotile} (TriggerTile{ttfeature=TK.OpenTo _} : _) t | Tile.isClosable cotile t = "already open" guessAlter _ (TriggerTile{ttfeature=TK.OpenTo _} : _) _ = "cannot be opened" guessAlter COps{cotile} (TriggerTile{ttfeature=TK.CloseTo _} : _) t | Tile.isOpenable cotile t = "already closed" guessAlter _ (TriggerTile{ttfeature=TK.CloseTo _} : _) _ = "cannot be closed" guessAlter _ _ _ = "never mind" -- * AlterWithPointer -- | Try to alter a tile using a feature under the pointer. alterWithPointerHuman :: MonadClientUI m => [TriggerTile] -> m (FailOrCmd RequestTimed) alterWithPointerHuman ts = do COps{cotile} <- getsState scops lidV <- viewedLevelUI lvl@Level{lxsize, lysize} <- getLevel lidV Point{..} <- getsSession spointer let tpos = Point px (py - mapStartY) t = lvl `at` tpos if px >= 0 && py - mapStartY >= 0 && px < lxsize && py - mapStartY < lysize then alterTileAtPos ts tpos $ "the" <+> TK.tname (okind cotile t) else do stopPlayBack failWith "never mind" -- * Help -- | Display command help. helpHuman :: MonadClientUI m => (HumanCmd -> m (Either MError ReqUI)) -> m (Either MError ReqUI) helpHuman cmdAction = do cops <- getsState scops lidV <- viewedLevelUI Level{lxsize, lysize} <- getLevel lidV keyb <- getsSession sbinding let keyH = keyHelp cops keyb 1 splitHelp (t, okx) = splitOKX lxsize (lysize + 3) (textToAL t) [K.spaceKM, K.escKM] okx sli = toSlideshow $ concat $ map splitHelp keyH ekm <- displayChoiceScreen "help" ColorFull True sli [K.spaceKM, K.escKM] case ekm of Left km -> case km `M.lookup` bcmdMap keyb of _ | km `elem` [K.escKM, K.spaceKM] -> return $ Left Nothing Just (_desc, _cats, cmd) -> cmdAction cmd Nothing -> weaveJust <$> failWith "never mind" Right _slot -> error $ "" `showFailure` ekm -- * Hint -- | Display hint or, if already displayed, display help. hintHuman :: MonadClientUI m => (HumanCmd -> m (Either MError ReqUI)) -> m (Either MError ReqUI) hintHuman cmdAction = do hintMode <- getsSession shintMode if hintMode == HintWiped then helpHuman cmdAction else do modifySession $ \sess -> sess {shintMode = HintShown} promptMainKeys return $ Left Nothing -- * Dashboard -- | Display the dashboard. dashboardHuman :: MonadClientUI m => (HumanCmd -> m (Either MError ReqUI)) -> m (Either MError ReqUI) dashboardHuman cmdAction = do lidV <- viewedLevelUI Level{lxsize, lysize} <- getLevel lidV keyb <- getsSession sbinding let keyL = 1 (ov0, kxs0) = okxsN keyb 1 keyL (const False) False CmdDashboard [] [] al1 = textToAL "Dashboard" splitHelp (al, okx) = splitOKX lxsize (lysize + 1) al [K.escKM] okx sli = toSlideshow $ splitHelp (al1, (ov0, kxs0)) extraKeys = [K.escKM] ekm <- displayChoiceScreen "dashboard" ColorFull False sli extraKeys case ekm of Left km -> case km `M.lookup` bcmdMap keyb of _ | km == K.escKM -> weaveJust <$> failWith "never mind" Just (_desc, _cats, cmd) -> cmdAction cmd Nothing -> weaveJust <$> failWith "never mind" Right _slot -> error $ "" `showFailure` ekm -- * ItemMenu itemMenuHuman :: MonadClientUI m => (HumanCmd -> m (Either MError ReqUI)) -> m (Either MError ReqUI) itemMenuHuman cmdAction = do itemSel <- getsSession sitemSel case itemSel of Just (iid, fromCStore, _) -> do leader <- getLeaderUI b <- getsState $ getActorBody leader bUI <- getsSession $ getActorUI leader bag <- getsState $ getBodyStoreBag b fromCStore case iid `EM.lookup` bag of Nothing -> weaveJust <$> failWith "no item to open item menu for" Just kit -> do ar <- getsState $ getActorAspect leader itemFull <- getsState $ itemToFull iid lidV <- viewedLevelUI Level{lxsize, lysize} <- getLevel lidV localTime <- getsState $ getLocalTime (blid b) found <- getsState $ findIid leader (bfid b) iid factionD <- getsState sfactionD sactorUI <- getsSession sactorUI let !_A = assert (not (null found) || fromCStore == CGround `blame` (iid, leader)) () fAlt (aid, (_, store)) = aid /= leader || store /= fromCStore foundAlt = filter fAlt found foundUI = map (\(aid, bs) -> (aid, bs, sactorUI EM.! aid)) foundAlt foundKeys = map (K.KM K.NoModifier . K.Fun) [1 .. length foundUI] -- starting from 1! ppLoc bUI2 store = let phr = makePhrase $ ppCStoreWownW False store $ partActor bUI2 in "[" ++ T.unpack phr ++ "]" foundTexts = map (\(_, (_, store), bUI2) -> ppLoc bUI2 store) foundUI foundPrefix = textToAL $ if null foundTexts then "" else "The item is also in:" desc = itemDesc False (bfid b) factionD (IA.aHurtMelee ar) fromCStore localTime itemFull kit alPrefix = splitAttrLine lxsize $ desc <+:> foundPrefix ystart = length alPrefix - 1 xstart = length (last alPrefix) + 1 ks = zip foundKeys $ map (\(_, (_, store), bUI2) -> ppLoc bUI2 store) foundUI (ovFoundRaw, kxsFound) = wrapOKX ystart xstart lxsize ks ovFound = glueLines alPrefix ovFoundRaw report <- getReportUI keyb <- getsSession sbinding actorSk <- leaderSkillsClientUI let calmE = calmEnough b ar greyedOut cmd = not calmE && fromCStore == CSha || case cmd of ByAimMode{..} -> greyedOut exploration || greyedOut aiming ComposeIfLocal cmd1 cmd2 -> greyedOut cmd1 || greyedOut cmd2 ComposeUnlessError cmd1 cmd2 -> greyedOut cmd1 || greyedOut cmd2 Compose2ndLocal cmd1 cmd2 -> greyedOut cmd1 || greyedOut cmd2 MoveItem stores destCStore _ _ -> fromCStore `notElem` stores || not calmE && CSha == destCStore || destCStore == CEqp && eqpOverfull b 1 Apply{} -> let skill = EM.findWithDefault 0 AbApply actorSk in not $ either (const False) id $ permittedApply localTime skill calmE itemFull kit Project{} -> let skill = EM.findWithDefault 0 AbProject actorSk in not $ either (const False) id $ permittedProject False skill calmE itemFull _ -> False fmt n k h = " " <> T.justifyLeft n ' ' k <+> h keyL = 11 keyCaption = fmt keyL "keys" "command" offset = 1 + length ovFound (ov0, kxs0) = okxsN keyb offset keyL greyedOut True CmdItemMenu [keyCaption] [] t0 = makeSentence [ MU.SubjectVerbSg (partActor bUI) "choose" , "an item", MU.Text $ ppCStoreIn fromCStore ] al1 = renderReport report <+:> textToAL t0 splitHelp (al, okx) = splitOKX lxsize (lysize + 1) al [K.spaceKM, K.escKM] okx sli = toSlideshow $ splitHelp (al1, (ovFound ++ ov0, kxsFound ++ kxs0)) extraKeys = [K.spaceKM, K.escKM] ++ foundKeys recordHistory -- report shown (e.g., leader switch), save to history ekm <- displayChoiceScreen "item menu" ColorFull False sli extraKeys case ekm of Left km -> case km `M.lookup` bcmdMap keyb of _ | km == K.escKM -> weaveJust <$> failWith "never mind" _ | km == K.spaceKM -> return $ Left Nothing _ | km `elem` foundKeys -> case km of K.KM{key=K.Fun n} -> do let (newAid, (bNew, newCStore)) = foundAlt !! (n - 1) fact <- getsState $ (EM.! bfid bNew) . sfactionD let (autoDun, _) = autoDungeonLevel fact if | blid bNew /= blid b && autoDun -> weaveJust <$> failSer NoChangeDunLeader | otherwise -> do void $ pickLeader True newAid modifySession $ \sess -> sess {sitemSel = Just (iid, newCStore, False)} itemMenuHuman cmdAction _ -> error $ "" `showFailure` km Just (_desc, _cats, cmd) -> do modifySession $ \sess -> sess {sitemSel = Just (iid, fromCStore, True)} res <- cmdAction cmd modifySession $ \sess -> sess {sitemSel = Just (iid, fromCStore, False)} return res Nothing -> weaveJust <$> failWith "never mind" Right _slot -> error $ "" `showFailure` ekm Nothing -> weaveJust <$> failWith "no item to open item menu for" -- * ChooseItemMenu chooseItemMenuHuman :: MonadClientUI m => (HumanCmd -> m (Either MError ReqUI)) -> ItemDialogMode -> m (Either MError ReqUI) chooseItemMenuHuman cmdAction c = do res <- chooseItemDialogMode c case res of Right c2 -> do res2 <- itemMenuHuman cmdAction case res2 of Left Nothing -> chooseItemMenuHuman cmdAction c2 _ -> return res2 Left err -> return $ Left $ Just err -- * MainMenu artAtSize :: MonadClientUI m => m [Text] artAtSize = do cops <- getsState scops let stdRuleset = getStdRuleset cops lxsize = fst normalLevelBound + 1 lysize = snd normalLevelBound + 4 xoffset = (80 - lxsize) `div` 2 yoffset = (45 - lysize) `div` 2 tlines = T.lines $ rmainMenuArt stdRuleset f = T.take lxsize . T.drop xoffset return $! map f $ take lysize $ drop yoffset tlines -- We detect the place for the version string by searching for 'Version' -- in the last line of the picture. If it doesn't fit, we shift, if everything -- else fails, only then we crop. We don't assume any line length. artWithVersion :: MonadClientUI m => m [String] artWithVersion = do cops <- getsState scops let stdRuleset = getStdRuleset cops pasteVersion :: [Text] -> [String] pasteVersion art = let exeVersion = rexeVersion stdRuleset libVersion = Self.version version = "Version " ++ showVersion exeVersion ++ " (frontend: " ++ frontendName ++ ", engine: LambdaHack " ++ showVersion libVersion ++ ") " versionLen = length version lastOriginal = last art (prefix, versionSuffix) = T.breakOn "Version" lastOriginal suffix = drop versionLen $ T.unpack versionSuffix overfillLen = versionLen - T.length versionSuffix prefixModified = T.unpack $ T.dropEnd overfillLen prefix lastModified = prefixModified ++ version ++ suffix in map T.unpack (init art) ++ [lastModified] mainMenuArt <- artAtSize return $! pasteVersion mainMenuArt generateMenu :: MonadClientUI m => (HumanCmd -> m (Either MError ReqUI)) -> [(K.KM, (Text, HumanCmd))] -> [String] -> String -> m (Either MError ReqUI) generateMenu cmdAction kds gameInfo menuName = do art <- artWithVersion let bindingLen = 30 emptyInfo = repeat $ replicate bindingLen ' ' bindings = -- key bindings to display let fmt (k, (d, _)) = ( Just k , T.unpack $ T.justifyLeft bindingLen ' ' $ T.justifyLeft 3 ' ' (T.pack $ K.showKM k) <> " " <> d ) in map fmt kds overwrite :: [(Int, String)] -> [(String, Maybe KYX)] overwrite = -- overwrite the art with key bindings and other lines let over [] (_, line) = ([], (line, Nothing)) over bs@((mkey, binding) : bsRest) (y, line) = let (prefix, lineRest) = break (=='{') line (braces, suffix) = span (=='{') lineRest in if length braces >= bindingLen then let lenB = length binding post = drop (lenB - length braces) suffix len = length prefix yxx key = (Left [key], (y, len, len + lenB)) myxx = yxx <$> mkey in (bsRest, (prefix <> binding <> post, myxx)) else (bs, (line, Nothing)) in snd . mapAccumL over (zip (repeat Nothing) gameInfo ++ bindings ++ zip (repeat Nothing) emptyInfo) menuOverwritten = overwrite $ zip [0..] art (menuOvLines, mkyxs) = unzip menuOverwritten kyxs = catMaybes mkyxs ov = map stringToAL menuOvLines ekm <- displayChoiceScreen menuName ColorFull True (menuToSlideshow (ov, kyxs)) [K.escKM] case ekm of Left km -> case km `lookup` kds of Just (_desc, cmd) -> cmdAction cmd Nothing -> weaveJust <$> failWith "never mind" Right _slot -> error $ "" `showFailure` ekm -- | Display the main menu. mainMenuHuman :: MonadClientUI m => (HumanCmd -> m (Either MError ReqUI)) -> m (Either MError ReqUI) mainMenuHuman cmdAction = do cops <- getsState scops Binding{bcmdList} <- getsSession sbinding gameMode <- getGameMode snxtScenario <- getsClient snxtScenario let nxtGameName = mname $ nxtGameMode cops snxtScenario tnextScenario = "pick next:" <+> nxtGameName -- Key-description-command tuples. kds = (K.mkKM "p", (tnextScenario, GameScenarioIncr)) : [ (km, (desc, cmd)) | (km, ([CmdMainMenu], desc, cmd)) <- bcmdList ] bindingLen = 30 gameName = mname gameMode gameInfo = map T.unpack [ T.justifyLeft bindingLen ' ' "" , T.justifyLeft bindingLen ' ' $ "Now playing:" <+> gameName , T.justifyLeft bindingLen ' ' "" ] generateMenu cmdAction kds gameInfo "main" -- * SettingsMenu -- | Display the settings menu. settingsMenuHuman :: MonadClientUI m => (HumanCmd -> m (Either MError ReqUI)) -> m (Either MError ReqUI) settingsMenuHuman cmdAction = do markSuspect <- getsClient smarkSuspect markVision <- getsSession smarkVision markSmell <- getsSession smarkSmell side <- getsClient sside factTactic <- getsState $ ftactic . gplayer . (EM.! side) . sfactionD let offOn b = if b then "on" else "off" offOnAll n = case n of 0 -> "low" 1 -> "medium" 2 -> "high" _ -> error $ "" `showFailure` n tsuspect = "suspect terrain:" <+> offOnAll markSuspect tvisible = "visible zone:" <+> offOn markVision tsmell = "smell clues:" <+> offOn markSmell thenchmen = "tactic:" <+> tshow factTactic -- Key-description-command tuples. kds = [ (K.mkKM "s", (tsuspect, MarkSuspect)) , (K.mkKM "v", (tvisible, MarkVision)) , (K.mkKM "c", (tsmell, MarkSmell)) , (K.mkKM "t", (thenchmen, Tactic)) , (K.mkKM "Escape", ("back to main menu", MainMenu)) ] bindingLen = 30 gameInfo = map T.unpack [ T.justifyLeft bindingLen ' ' "" , T.justifyLeft bindingLen ' ' "Convenience settings:" , T.justifyLeft bindingLen ' ' "" ] generateMenu cmdAction kds gameInfo "settings" -- * ChallengesMenu -- | Display the challenges menu. challengesMenuHuman :: MonadClientUI m => (HumanCmd -> m (Either MError ReqUI)) -> m (Either MError ReqUI) challengesMenuHuman cmdAction = do curChal <- getsClient scurChal nxtChal <- getsClient snxtChal let offOn b = if b then "on" else "off" tcurDiff = "* difficulty:" <+> tshow (cdiff curChal) tnextDiff = "difficulty:" <+> tshow (cdiff nxtChal) tcurWolf = "* lone wolf:" <+> offOn (cwolf curChal) tnextWolf = "lone wolf:" <+> offOn (cwolf nxtChal) tcurFish = "* cold fish:" <+> offOn (cfish curChal) tnextFish = "cold fish:" <+> offOn (cfish nxtChal) -- Key-description-command tuples. kds = [ (K.mkKM "d", (tnextDiff, GameDifficultyIncr)) , (K.mkKM "w", (tnextWolf, GameWolfToggle)) , (K.mkKM "f", (tnextFish, GameFishToggle)) , (K.mkKM "Escape", ("back to main menu", MainMenu)) ] bindingLen = 30 gameInfo = map T.unpack [ T.justifyLeft bindingLen ' ' "Current challenges:" , T.justifyLeft bindingLen ' ' "" , T.justifyLeft bindingLen ' ' tcurDiff , T.justifyLeft bindingLen ' ' tcurWolf , T.justifyLeft bindingLen ' ' tcurFish , T.justifyLeft bindingLen ' ' "" , T.justifyLeft bindingLen ' ' "Next game challenges:" , T.justifyLeft bindingLen ' ' "" ] generateMenu cmdAction kds gameInfo "challenge" -- * GameScenarioIncr gameScenarioIncr :: MonadClientUI m => m () gameScenarioIncr = modifyClient $ \cli -> cli {snxtScenario = snxtScenario cli + 1} -- * GameDifficultyIncr gameDifficultyIncr :: MonadClientUI m => m () gameDifficultyIncr = do nxtDiff <- getsClient $ cdiff . snxtChal let delta = 1 d | nxtDiff + delta > difficultyBound = 1 | nxtDiff + delta < 1 = difficultyBound | otherwise = nxtDiff + delta modifyClient $ \cli -> cli {snxtChal = (snxtChal cli) {cdiff = d} } -- * GameWolfToggle gameWolfToggle :: MonadClientUI m => m () gameWolfToggle = modifyClient $ \cli -> cli {snxtChal = (snxtChal cli) {cwolf = not (cwolf (snxtChal cli))} } -- * GameFishToggle gameFishToggle :: MonadClientUI m => m () gameFishToggle = modifyClient $ \cli -> cli {snxtChal = (snxtChal cli) {cfish = not (cfish (snxtChal cli))} } -- * GameRestart gameRestartHuman :: MonadClientUI m => m (FailOrCmd ReqUI) gameRestartHuman = do cops <- getsState scops isNoConfirms <- isNoConfirmsGame gameMode <- getGameMode snxtScenario <- getsClient snxtScenario let nxtGameName = mname $ nxtGameMode cops snxtScenario b <- if isNoConfirms then return True else displayYesNo ColorBW $ "You just requested a new" <+> nxtGameName <+> "game. The progress of the ongoing" <+> mname gameMode <+> "game will be lost! Are you sure?" if b then do snxtChal <- getsClient snxtChal -- This ignores all but the first word of game mode names picked -- via main menu and assumes the fist word of such game modes -- is present in their frequencies. let nxtGameGroup = toGroupName $ head $ T.words nxtGameName return $ Right $ ReqUIGameRestart nxtGameGroup snxtChal else do msg2 <- rndToActionForget $ oneOf [ "yea, would be a pity to leave them all to die" , "yea, a shame to get your team stranded" ] failWith msg2 nxtGameMode :: COps -> Int -> ModeKind nxtGameMode COps{comode} snxtScenario = let f acc _p _i a = a : acc campaignModes = ofoldlGroup' comode "campaign scenario" f [] in campaignModes !! (snxtScenario `mod` length campaignModes) -- * GameExit gameExitHuman :: MonadClientUI m => m ReqUI gameExitHuman = do -- Announce before the saving started, since it can take a while. promptAdd1 "Saving game. The program stops now." return ReqUIGameSaveAndExit -- * GameSave gameSaveHuman :: MonadClientUI m => m ReqUI gameSaveHuman = do -- Announce before the saving started, since it can take a while. promptAdd1 "Saving game backup." return ReqUIGameSave -- * Tactic -- 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. tacticHuman :: MonadClientUI m => m (FailOrCmd ReqUI) tacticHuman = do fid <- getsClient sside fromT <- getsState $ ftactic . gplayer . (EM.! fid) . sfactionD let toT = if fromT == maxBound then minBound else succ fromT go <- displaySpaceEsc ColorFull $ "(Beware, work in progress!)" <+> "Current henchmen tactic is" <+> tshow fromT <+> "(" <> describeTactic fromT <> ")." <+> "Switching tactic to" <+> tshow toT <+> "(" <> describeTactic toT <> ")." <+> "This clears targets of all henchmen (non-leader teammates)." <+> "New targets will be picked according to new tactic." if not go then failWith "tactic change canceled" else return $ Right $ ReqUITactic toT -- * Automate automateHuman :: MonadClientUI m => m (FailOrCmd ReqUI) automateHuman = do clearAimMode go <- displaySpaceEsc ColorBW "Ceding control to AI (press ESC to regain)." if not go then failWith "automation canceled" else return $ Right ReqUIAutomate LambdaHack-0.8.3.0/Game/LambdaHack/Client/UI/Key.hs0000644000000000000000000004205213315545734017471 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} -- | Frontend-independent keyboard input operations. module Game.LambdaHack.Client.UI.Key ( Key(..), Modifier(..), KM(..), KMP(..) , showKey, showKM , escKM, spaceKM, safeSpaceKM, returnKM , pgupKM, pgdnKM, wheelNorthKM, wheelSouthKM , upKM, downKM, leftKM, rightKM , homeKM, endKM, backspaceKM , leftButtonReleaseKM, rightButtonReleaseKM , dirAllKey, handleDir, moveBinding, mkKM, mkChar, mkKP , keyTranslate, keyTranslateWeb #ifdef EXPOSE_INTERNAL -- * Internal operations , dirKeypadKey, dirKeypadShiftChar, dirKeypadShiftKey , dirLaptopKey, dirLaptopShiftKey , dirViChar, dirViKey, dirViShiftKey , dirMoveNoModifier, dirRunNoModifier, dirRunControl, dirRunShift #endif ) where import Prelude () import Game.LambdaHack.Common.Prelude hiding (Alt, Left, Right) import Control.DeepSeq import Data.Binary import qualified Data.Char as Char import GHC.Generics (Generic) 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 | PrintScreen | Home | KP Char -- ^ a keypad key for a character (digits and operators) | Char Char -- ^ a single printable character | Fun Int -- ^ function key | LeftButtonPress -- ^ left mouse button pressed | MiddleButtonPress -- ^ middle mouse button pressed | RightButtonPress -- ^ right mouse button pressed | LeftButtonRelease -- ^ left mouse button released | MiddleButtonRelease -- ^ middle mouse button released | RightButtonRelease -- ^ right mouse button released | WheelNorth -- ^ mouse wheel rotated north | WheelSouth -- ^ mouse wheel rotated south | Unknown String -- ^ an unknown key, registered to warn the user | DeadKey deriving (Ord, Eq, Generic) instance Binary Key instance NFData Key -- | Our own encoding of modifiers. data Modifier = NoModifier | Shift | Control | Alt deriving (Show, Ord, Eq, Generic) instance Binary Modifier instance NFData Modifier -- | Key and modifier. data KM = KM { modifier :: Modifier , key :: Key } deriving (Ord, Eq, Generic) instance Binary KM instance NFData KM instance Show KM where show = showKM -- | Key, modifier and position of mouse pointer. data KMP = KMP { kmpKeyMod :: KM , kmpPointer :: Point } -- | Common and terse names for keys. showKey :: Key -> String showKey Esc = "ESC" showKey Return = "RET" showKey Space = "SPACE" showKey Tab = "TAB" showKey BackTab = "S-TAB" showKey BackSpace = "BACKSPACE" showKey Up = "UP" showKey Down = "DOWN" showKey Left = "LEFT" showKey Right = "RIGHT" showKey Home = "HOME" showKey End = "END" showKey PgUp = "PGUP" showKey PgDn = "PGDN" showKey Begin = "BEGIN" showKey Insert = "INS" showKey Delete = "DEL" showKey PrintScreen = "PRTSCR" showKey (KP c) = "KP_" ++ [c] showKey (Char c) = [c] showKey (Fun n) = "F" ++ show n showKey LeftButtonPress = "LMB-PRESS" showKey MiddleButtonPress = "MMB-PRESS" showKey RightButtonPress = "RMB-PRESS" showKey LeftButtonRelease = "LMB" showKey MiddleButtonRelease = "MMB" showKey RightButtonRelease = "RMB" showKey WheelNorth = "WHEEL-UP" showKey WheelSouth = "WHEEL-DN" showKey (Unknown s) = "'" ++ s ++ "'" showKey DeadKey = "DEADKEY" -- | Show a key with a modifier, if any. showKM :: KM -> String showKM KM{modifier=Shift, key} = "S-" ++ showKey key showKM KM{modifier=Control, key} = "C-" ++ showKey key showKM KM{modifier=Alt, key} = "A-" ++ showKey key showKM KM{modifier=NoModifier, key} = showKey key escKM :: KM escKM = KM NoModifier Esc spaceKM :: KM spaceKM = KM NoModifier Space safeSpaceKM :: KM safeSpaceKM = KM NoModifier $ Unknown "SAFE_SPACE" returnKM :: KM returnKM = KM NoModifier Return pgupKM :: KM pgupKM = KM NoModifier PgUp pgdnKM :: KM pgdnKM = KM NoModifier PgDn wheelNorthKM :: KM wheelNorthKM = KM NoModifier WheelNorth wheelSouthKM :: KM wheelSouthKM = KM NoModifier WheelSouth upKM :: KM upKM = KM NoModifier Up downKM :: KM downKM = KM NoModifier Down leftKM :: KM leftKM = KM NoModifier Left rightKM :: KM rightKM = KM NoModifier Right homeKM :: KM homeKM = KM NoModifier Home endKM :: KM endKM = KM NoModifier End backspaceKM :: KM backspaceKM = KM NoModifier BackSpace leftButtonReleaseKM :: KM leftButtonReleaseKM = KM NoModifier LeftButtonRelease rightButtonReleaseKM :: KM rightButtonReleaseKM = KM NoModifier RightButtonRelease 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 uVi uLaptop = dirKeypadKey ++ if | uVi -> dirViKey | uLaptop -> dirLaptopKey | otherwise -> [] dirRunNoModifier :: Bool -> Bool -> [Key] dirRunNoModifier uVi uLaptop = dirKeypadShiftKey ++ if | uVi -> dirViShiftKey | uLaptop -> dirLaptopShiftKey | otherwise -> [] dirRunControl :: [Key] dirRunControl = dirKeypadKey ++ dirKeypadShiftKey ++ map Char dirKeypadShiftChar dirRunShift :: [Key] dirRunShift = dirRunControl dirAllKey :: Bool -> Bool -> [Key] dirAllKey uVi uLaptop = dirMoveNoModifier uVi uLaptop ++ dirRunNoModifier uVi uLaptop ++ dirRunControl -- | Configurable event handler for the direction keys. -- Used for directed commands such as close door. handleDir :: Bool -> Bool -> KM -> Maybe Vector handleDir uVi uLaptop KM{modifier=NoModifier, key} = let assocs = zip (dirAllKey uVi uLaptop) $ cycle moves in lookup key assocs handleDir _ _ _ = Nothing -- | Binding of both sets of movement keys, vi and laptop. moveBinding :: Bool -> Bool -> (Vector -> a) -> (Vector -> a) -> [(KM, a)] moveBinding uVi uLaptop move run = let assign f (km, dir) = (km, f dir) mapMove modifier keys = map (assign move) (zip (map (KM modifier) keys) $ cycle moves) mapRun modifier keys = map (assign run) (zip (map (KM modifier) keys) $ cycle moves) in mapMove NoModifier (dirMoveNoModifier uVi uLaptop) ++ mapRun NoModifier (dirRunNoModifier uVi uLaptop) ++ mapRun Control dirRunControl ++ mapRun Shift dirRunShift mkKM :: String -> KM mkKM s = let mkKey sk = case keyTranslate sk of Unknown _ -> error $ "unknown key" `showFailure` s key -> key in case s of 'S':'-':rest -> KM Shift (mkKey rest) 'C':'-':rest -> KM Control (mkKey rest) 'A':'-':rest -> KM Alt (mkKey rest) _ -> KM NoModifier (mkKey s) mkChar :: Char -> KM mkChar c = KM NoModifier $ Char c mkKP :: Char -> KM mkKP c = KM NoModifier $ KP c -- | Translate key from a GTK string description to our internal key type. -- To be used, in particular, for the command bindings and macros -- in the config file. -- -- See keyTranslate :: String -> Key keyTranslate "less" = Char '<' keyTranslate "greater" = Char '>' keyTranslate "period" = Char '.' keyTranslate "colon" = Char ':' keyTranslate "semicolon" = Char ';' keyTranslate "comma" = Char ',' keyTranslate "question" = Char '?' keyTranslate "numbersign" = Char '#' keyTranslate "dollar" = Char '$' keyTranslate "parenleft" = Char '(' keyTranslate "parenright" = Char ')' keyTranslate "asterisk" = Char '*' -- for latop movement keys keyTranslate "KP_Multiply" = KP '*' -- for keypad aiming keyTranslate "slash" = Char '/' keyTranslate "KP_Divide" = KP '/' keyTranslate "bar" = Char '|' keyTranslate "backslash" = Char '\\' keyTranslate "asciicircum" = Char '^' keyTranslate "underscore" = Char '_' keyTranslate "minus" = Char '-' keyTranslate "KP_Subtract" = Char '-' -- KP and normal are merged here keyTranslate "plus" = Char '+' keyTranslate "KP_Add" = Char '+' -- KP and normal are merged here keyTranslate "equal" = Char '=' keyTranslate "bracketleft" = Char '[' keyTranslate "bracketright" = Char ']' keyTranslate "braceleft" = Char '{' keyTranslate "braceright" = Char '}' keyTranslate "caret" = Char '^' keyTranslate "ampersand" = Char '&' keyTranslate "at" = Char '@' keyTranslate "asciitilde" = Char '~' keyTranslate "grave" = Char '`' keyTranslate "exclam" = Char '!' keyTranslate "apostrophe" = Char '\'' keyTranslate "Escape" = Esc keyTranslate "ESC" = Esc keyTranslate "Return" = Return keyTranslate "RET" = Return keyTranslate "space" = Space keyTranslate "SPACE" = Space keyTranslate "Tab" = Tab keyTranslate "TAB" = Tab keyTranslate "BackTab" = BackTab keyTranslate "ISO_Left_Tab" = BackTab keyTranslate "BackSpace" = BackSpace keyTranslate "BACKSPACE" = BackSpace keyTranslate "Up" = Up keyTranslate "UP" = Up keyTranslate "KP_Up" = Up keyTranslate "Down" = Down keyTranslate "DOWN" = Down keyTranslate "KP_Down" = Down keyTranslate "Left" = Left keyTranslate "LEFT" = Left keyTranslate "KP_Left" = Left keyTranslate "Right" = Right keyTranslate "RIGHT" = Right keyTranslate "KP_Right" = Right keyTranslate "Home" = Home keyTranslate "HOME" = Home keyTranslate "KP_Home" = Home keyTranslate "End" = End keyTranslate "END" = End keyTranslate "KP_End" = End keyTranslate "Page_Up" = PgUp keyTranslate "PGUP" = PgUp keyTranslate "KP_Page_Up" = PgUp keyTranslate "Prior" = PgUp keyTranslate "KP_Prior" = PgUp keyTranslate "Page_Down" = PgDn keyTranslate "PGDN" = PgDn keyTranslate "KP_Page_Down" = PgDn keyTranslate "Next" = PgDn keyTranslate "KP_Next" = PgDn keyTranslate "Begin" = Begin keyTranslate "BEGIN" = Begin keyTranslate "KP_Begin" = Begin keyTranslate "Clear" = Begin keyTranslate "KP_Clear" = Begin keyTranslate "Center" = Begin keyTranslate "KP_Center" = Begin keyTranslate "Insert" = Insert keyTranslate "INS" = Insert keyTranslate "KP_Insert" = Insert keyTranslate "Delete" = Delete keyTranslate "DEL" = Delete keyTranslate "KP_Delete" = Delete keyTranslate "KP_Enter" = Return keyTranslate "F1" = Fun 1 keyTranslate "F2" = Fun 2 keyTranslate "F3" = Fun 3 keyTranslate "F4" = Fun 4 keyTranslate "F5" = Fun 5 keyTranslate "F6" = Fun 6 keyTranslate "F7" = Fun 7 keyTranslate "F8" = Fun 8 keyTranslate "F9" = Fun 9 keyTranslate "F10" = Fun 10 keyTranslate "F11" = Fun 11 keyTranslate "F12" = Fun 12 keyTranslate "LeftButtonPress" = LeftButtonPress keyTranslate "LMB-PRESS" = LeftButtonPress keyTranslate "MiddleButtonPress" = MiddleButtonPress keyTranslate "MMB-PRESS" = MiddleButtonPress keyTranslate "RightButtonPress" = RightButtonPress keyTranslate "RMB-PRESS" = RightButtonPress keyTranslate "LeftButtonRelease" = LeftButtonRelease keyTranslate "LMB" = LeftButtonRelease keyTranslate "MiddleButtonRelease" = MiddleButtonRelease keyTranslate "MMB" = MiddleButtonRelease keyTranslate "RightButtonRelease" = RightButtonRelease keyTranslate "RMB" = RightButtonRelease keyTranslate "WheelNorth" = WheelNorth keyTranslate "WHEEL-UP" = WheelNorth keyTranslate "WheelSouth" = WheelSouth keyTranslate "WHEEL-DN" = WheelSouth -- dead keys keyTranslate "Shift_L" = DeadKey keyTranslate "Shift_R" = DeadKey keyTranslate "Control_L" = DeadKey keyTranslate "Control_R" = DeadKey keyTranslate "Super_L" = DeadKey keyTranslate "Super_R" = DeadKey keyTranslate "Menu" = DeadKey keyTranslate "Alt_L" = DeadKey keyTranslate "Alt_R" = DeadKey keyTranslate "Meta_L" = DeadKey keyTranslate "Meta_R" = DeadKey keyTranslate "ISO_Level2_Shift" = DeadKey keyTranslate "ISO_Level3_Shift" = DeadKey keyTranslate "ISO_Level2_Latch" = DeadKey keyTranslate "ISO_Level3_Latch" = DeadKey keyTranslate "Num_Lock" = DeadKey keyTranslate "Caps_Lock" = DeadKey keyTranslate "VoidSymbol" = DeadKey -- numeric keypad keyTranslate ['K','P','_',c] = KP c -- standard characters keyTranslate [c] = Char c keyTranslate s = Unknown s -- | Translate key from a Web API string description -- () -- to our internal key type. To be used in web frontends. -- The argument says whether Shift is pressed. keyTranslateWeb :: String -> Bool -> Key keyTranslateWeb "1" True = KP '1' keyTranslateWeb "2" True = KP '2' keyTranslateWeb "3" True = KP '3' keyTranslateWeb "4" True = KP '4' keyTranslateWeb "5" True = KP '5' keyTranslateWeb "6" True = KP '6' keyTranslateWeb "7" True = KP '7' keyTranslateWeb "8" True = KP '8' keyTranslateWeb "9" True = KP '9' keyTranslateWeb "End" True = KP '1' keyTranslateWeb "ArrowDown" True = KP '2' keyTranslateWeb "PageDown" True = KP '3' keyTranslateWeb "ArrowLeft" True = KP '4' keyTranslateWeb "Begin" True = KP '5' keyTranslateWeb "Clear" True = KP '5' keyTranslateWeb "ArrowRight" True = KP '6' keyTranslateWeb "Home" True = KP '7' keyTranslateWeb "ArrowUp" True = KP '8' keyTranslateWeb "PageUp" True = KP '9' keyTranslateWeb "Backspace" _ = BackSpace keyTranslateWeb "Tab" True = BackTab keyTranslateWeb "Tab" False = Tab keyTranslateWeb "BackTab" _ = BackTab keyTranslateWeb "Begin" _ = Begin keyTranslateWeb "Clear" _ = Begin keyTranslateWeb "Enter" _ = Return keyTranslateWeb "Esc" _ = Esc keyTranslateWeb "Escape" _ = Esc keyTranslateWeb "Del" _ = Delete keyTranslateWeb "Delete" _ = Delete keyTranslateWeb "Home" _ = Home keyTranslateWeb "Up" _ = Up keyTranslateWeb "ArrowUp" _ = Up keyTranslateWeb "Down" _ = Down keyTranslateWeb "ArrowDown" _ = Down keyTranslateWeb "Left" _ = Left keyTranslateWeb "ArrowLeft" _ = Left keyTranslateWeb "Right" _ = Right keyTranslateWeb "ArrowRight" _ = Right keyTranslateWeb "PageUp" _ = PgUp keyTranslateWeb "PageDown" _ = PgDn keyTranslateWeb "End" _ = End keyTranslateWeb "Insert" _ = Insert keyTranslateWeb "space" _ = Space keyTranslateWeb "Equals" _ = Char '=' keyTranslateWeb "Multiply" True = Char '*' -- for latop movement keys keyTranslateWeb "Multiply" False = KP '*' -- for keypad aiming keyTranslateWeb "*" False = KP '*' -- for keypad aiming keyTranslateWeb "Add" _ = Char '+' -- KP and normal are merged here keyTranslateWeb "Subtract" _ = Char '-' -- KP and normal are merged here keyTranslateWeb "Divide" True = Char '/' keyTranslateWeb "Divide" False = KP '/' keyTranslateWeb "/" False = KP '/' keyTranslateWeb "Decimal" _ = Char '.' -- dot and comma are merged here keyTranslateWeb "Separator" _ = Char '.' -- to sidestep national standards keyTranslateWeb "F1" _ = Fun 1 keyTranslateWeb "F2" _ = Fun 2 keyTranslateWeb "F3" _ = Fun 3 keyTranslateWeb "F4" _ = Fun 4 keyTranslateWeb "F5" _ = Fun 5 keyTranslateWeb "F6" _ = Fun 6 keyTranslateWeb "F7" _ = Fun 7 keyTranslateWeb "F8" _ = Fun 8 keyTranslateWeb "F9" _ = Fun 9 keyTranslateWeb "F10" _ = Fun 10 keyTranslateWeb "F11" _ = Fun 11 keyTranslateWeb "F12" _ = Fun 12 -- dead keys keyTranslateWeb "Dead" _ = DeadKey keyTranslateWeb "Shift" _ = DeadKey keyTranslateWeb "Control" _ = DeadKey keyTranslateWeb "Meta" _ = DeadKey keyTranslateWeb "Menu" _ = DeadKey keyTranslateWeb "ContextMenu" _ = DeadKey keyTranslateWeb "Alt" _ = DeadKey keyTranslateWeb "AltGraph" _ = DeadKey keyTranslateWeb "Num_Lock" _ = DeadKey keyTranslateWeb "CapsLock" _ = DeadKey keyTranslateWeb "Win" _ = DeadKey -- browser quirks keyTranslateWeb "Unidentified" _ = Begin -- hack for Firefox keyTranslateWeb ['\ESC'] _ = Esc keyTranslateWeb [' '] _ = Space keyTranslateWeb ['\n'] _ = Return keyTranslateWeb ['\r'] _ = DeadKey keyTranslateWeb ['\t'] _ = Tab -- standard characters keyTranslateWeb [c] _ = Char c keyTranslateWeb s _ = Unknown s LambdaHack-0.8.3.0/Game/LambdaHack/Client/UI/EffectDescription.hs0000644000000000000000000004323713315545734022347 0ustar0000000000000000-- | Description of effects. module Game.LambdaHack.Client.UI.EffectDescription ( DetailLevel(..), effectToSuffix, detectToObject, detectToVerb , slotToSentence, slotToName, slotToDesc, slotToDecorator, statSlots , kindAspectToSuffix, featureToSuff, featureToSentence, affixDice #ifdef EXPOSE_INTERNAL -- * Internal operations , tmodToSuff, affixBonus, wrapInParens, wrapInChevrons #endif ) where import Prelude () import Game.LambdaHack.Common.Prelude import qualified Data.Text as T import qualified NLP.Miniutter.English as MU import Game.LambdaHack.Client.UI.ActorUI import Game.LambdaHack.Common.Ability import Game.LambdaHack.Common.Actor import qualified Game.LambdaHack.Common.Dice as Dice import Game.LambdaHack.Common.ItemAspect (Aspect (..), EqpSlot (..)) import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.Time import Game.LambdaHack.Content.ItemKind data DetailLevel = DetailLow | DetailMedium | DetailHigh | DetailAll deriving (Eq, Ord, Enum, Bounded) -- | Suffix to append to a basic content name if the content causes the effect. -- -- We show absolute time in seconds, not @moves@, because actors can have -- different speeds (and actions can potentially take different time intervals). -- We call the time taken by one player move, when walking, a @move@. -- @Turn@ and @clip@ are used mostly internally, the former as an absolute -- time unit. -- We show distances in @steps@, because one step, from a tile to another -- tile, is always 1 meter. We don't call steps @tiles@, reserving -- that term for the context of terrain kinds or units of area. effectToSuffix :: DetailLevel -> Effect -> Text effectToSuffix detailLevel effect = case effect of Burn d -> wrapInParens (tshow d <+> if Dice.maxDice d > 1 then "burns" else "burn") Explode t -> "of" <+> tshow t <+> "explosion" RefillHP p | p > 0 -> "of healing" <+> wrapInParens (affixBonus p) RefillHP 0 -> error $ "" `showFailure` effect RefillHP p -> "of wounding" <+> wrapInParens (affixBonus p) RefillCalm p | p > 0 -> "of soothing" <+> wrapInParens (affixBonus p) RefillCalm 0 -> error $ "" `showFailure` effect RefillCalm p -> "of dismaying" <+> wrapInParens (affixBonus p) Dominate -> "of domination" Impress -> "of impression" Summon grp p -> makePhrase [ "of summoning" , if p <= 1 then "" else MU.Text $ tshow p , MU.Ws $ MU.Text $ tshow grp ] ApplyPerfume -> "of smell removal" Ascend True -> "of ascending" Ascend False -> "of descending" Escape{} -> "of escaping" Paralyze dice -> let time = case Dice.reduceDice dice of Nothing -> tshow dice <+> "* 0.05s" Just p -> let 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.maxDice dice <= 9 -> "of blinking" <+> wrapInParens (tshow dice) Teleport dice -> "of teleport" <+> wrapInParens (tshow dice) CreateItem COrgan grp tim -> let stime = if isTimerNone tim then "" else "for" <+> tshow tim <> ":" in "(keep" <+> stime <+> tshow grp <> ")" CreateItem{} -> "of gain" DropItem n k store grp -> let ntxt = if | n == 1 && k == maxBound -> "one kind of" | n == maxBound && k == maxBound -> "all kinds of" | otherwise -> "" (verb, fromStore) = if store == COrgan then ("nullify", "") else ("drop", "from" <+> snd (ppCStore store)) in "of" <+> verb <+> ntxt <+> tshow grp <+> fromStore PolyItem -> "of repurpose on the ground" Identify -> "of identify" Detect d radius -> "of" <+> detectToObject d <+> "location" <+> wrapInParens (tshow radius) SendFlying tmod -> "of impact" <+> tmodToSuff "" tmod PushActor tmod -> "of pushing" <+> tmodToSuff "" tmod PullActor tmod -> "of pulling" <+> tmodToSuff "" tmod DropBestWeapon -> "of disarming" ActivateInv ' ' -> "of backpack burst" ActivateInv symbol -> "of burst '" <> T.singleton symbol <> "'" OneOf l -> let subject = if length l <= 5 then "marvel" else "wonder" header = makePhrase ["of", MU.CardinalWs (length l) subject] marvels = T.intercalate ", " $ map (effectToSuffix detailLevel) l in if detailLevel >= DetailAll && marvels /= "" then header <+> "[" <> marvels <> "]" else header OnSmash _ -> "" -- printed inside a separate section Recharging _ -> "" -- printed inside Periodic or Timeout Temporary _ -> "" -- only printed on destruction Composite effs -> T.intercalate " and then " $ filter (/= "") $ map (effectToSuffix detailLevel) effs detectToObject :: DetectKind -> Text detectToObject d = case d of DetectAll -> "" DetectActor -> "actor" DetectItem -> "item" DetectExit -> "exit" DetectHidden -> "secret" DetectEmbed -> "feature" detectToVerb :: DetectKind -> Text detectToVerb d = case d of DetectAll -> "map surrounding area" DetectActor -> "spot nearby" DetectItem -> "locate nearby" DetectExit -> "learn nearby" DetectHidden -> "uncover nearby" DetectEmbed -> "notice nearby" slotToSentence :: EqpSlot -> Text slotToSentence es = case es of EqpSlotMiscBonus -> "Those that don't scorn minor bonuses may equip it." EqpSlotAddHurtMelee -> "Veteran melee fighters are known to devote equipment slot to it." EqpSlotAddArmorMelee -> "Worn by people in risk of melee wounds." EqpSlotAddArmorRanged -> "People scared of shots in the dark wear it." EqpSlotAddMaxHP -> "The frail wear it to increase their Hit Point capacity." EqpSlotAddSpeed -> "The slughish equip it to speed up their whole life." EqpSlotAddSight -> "The short-sighted wear it to spot their demise sooner." EqpSlotLightSource -> "Explorers brave enough to highlight themselves put it in their equipment." EqpSlotWeapon -> "Melee fighters pick it for their weapon combo." EqpSlotMiscAbility -> "Those that don't scorn uncanny skills may equip it." EqpSlotAbMove -> "Those unskilled in movement equip it." EqpSlotAbMelee -> "Those unskilled in melee equip it." EqpSlotAbDisplace -> "Those unskilled in displacing equip it." EqpSlotAbAlter -> "Those unskilled in alteration equip it." EqpSlotAbProject -> "Those unskilled in flinging equip it." EqpSlotAbApply -> "Those unskilled in applying items equip it." _ -> error $ "should not be used in content" `showFailure` es slotToName :: EqpSlot -> Text slotToName eqpSlot = case eqpSlot of EqpSlotMiscBonus -> "misc bonuses" EqpSlotAddHurtMelee -> "to melee damage" EqpSlotAddArmorMelee -> "melee armor" EqpSlotAddArmorRanged -> "ranged armor" EqpSlotAddMaxHP -> "max HP" EqpSlotAddSpeed -> "speed" EqpSlotAddSight -> "sight radius" EqpSlotLightSource -> "shine radius" EqpSlotWeapon -> "weapon power" EqpSlotMiscAbility -> "misc abilities" EqpSlotAbMove -> tshow AbMove <+> "ability" EqpSlotAbMelee -> tshow AbMelee <+> "ability" EqpSlotAbDisplace -> tshow AbDisplace <+> "ability" EqpSlotAbAlter -> tshow AbAlter <+> "ability" EqpSlotAbProject -> tshow AbProject <+> "ability" EqpSlotAbApply -> tshow AbApply <+> "ability" EqpSlotAddMaxCalm -> "max Calm" EqpSlotAddSmell -> "smell radius" EqpSlotAddNocto -> "night vision radius" EqpSlotAddAggression -> "aggression level" EqpSlotAbWait -> tshow AbWait <+> "ability" EqpSlotAbMoveItem -> tshow AbMoveItem <+> "ability" slotToDesc :: EqpSlot -> Text slotToDesc eqpSlot = let statName = slotToName eqpSlot capName = "The '" <> statName <> "' stat" in capName <+> case eqpSlot of EqpSlotMiscBonus -> "represent the total power of assorted stat bonuses for the character." EqpSlotAddHurtMelee -> "is a percentage of additional damage dealt by the actor (either a character or a missile) with any weapon. The value is capped at 200%, then the armor percentage of the defender is subtracted from it and the resulting total is capped at 99%." EqpSlotAddArmorMelee -> "is a percentage of melee damage avoided by the actor. The value is capped at 200%, then the extra melee damage percentage of the attacker is subtracted from it and the resulting total is capped at 99% (always at least 1% of damage gets through). It includes 50% bonus from being braced for combat, if applicable." EqpSlotAddArmorRanged -> "is a percentage of ranged damage avoided by the actor. The value is capped at 200%, then the extra melee damage percentage of the attacker is subtracted from it and the resulting total is capped at 99% (always at least 1% of damage gets through). It includes 25% bonus from being braced for combat, if applicable." EqpSlotAddMaxHP -> "is a cap on HP of the actor, except for some rare effects able to overfill HP. At any direct enemy damage (but not, e.g., incremental poisoning damage or wounds inflicted by mishandling a device) HP is cut back to the cap." EqpSlotAddSpeed -> "is expressed in meters per second, which corresponds to map location (1m by 1m) per two standard turns (0.5s each). Thus actor at standard speed of 2m/s moves one location per standard turn." EqpSlotAddSight -> "is the limit of visibility in light. The radius is measured from the middle of the map location occupied by the character to the edge of the furthest covered location." EqpSlotLightSource -> "determines the maximal area lit by the actor. The radius is measured from the middle of the map location occupied by the character to the edge of the furthest covered location." EqpSlotWeapon -> "represents the total power of weapons equipped by the character." EqpSlotMiscAbility -> "represent the total power of assorted ability bonuses for the character." EqpSlotAbMove -> "determines whether the character can move. Actors not capable of movement can't be dominated." EqpSlotAbMelee -> "determines whether the character can melee. Actors that can't melee can still cause damage by flinging missiles or by ramming (being pushed) at opponents." EqpSlotAbDisplace -> "determines whether the character can displace adjacent actors. In some cases displacing is not possible regardless of ability: when the target is braced, dying, has no move ability or when both actors are supported by adjacent friendly units. Missiles can be displaced always, unless more than one occupies the map location." EqpSlotAbAlter -> "determines which kinds of terrain can be altered or triggered by the character. Opening doors and searching suspect tiles require ability 2, some stairs require 3, closing doors requires 4, others require 4 or 5. Actors not smart enough to be capable of using stairs can't be dominated." EqpSlotAbProject -> "determines which kinds of items the character can propel. Items that can be lobbed to explode at a precise location, such as flasks, require ability 3. Other items travel until they meet an obstacle and ability 1 is enough to fling them. In some cases, e.g., of too intricate or two awkward items at low Calm, throwing is not possible regardless of the ability value." EqpSlotAbApply -> "determines which kinds of items the character can activate. Items that assume literacy require ability 2, others can be used already at ability 1. In some cases, e.g., when the item needs recharging, has no possible effects or is too intricate for the character Calm level, applying may not be possible." EqpSlotAddMaxCalm -> "is a cap on Calm of the actor, except for some rare effects able to overfill Calm. At any direct enemy damage (but not, e.g., incremental poisoning damage or wounds inflicted by mishandling a device) Calm is lowered, sometimes very significantly and always at least back down to the cap." EqpSlotAddSmell -> "determines the maximal area smelled by the actor. The radius is measured from the middle of the map location occupied by the character to the edge of the furthest covered location." EqpSlotAddNocto -> "is the limit of visibility in dark. The radius is measured from the middle of the map location occupied by the character to the edge of the furthest covered location." EqpSlotAddAggression -> "represents the willingness of the actor to engage in combat, especially close quarters, and conversely, to break engagement when overpowered." EqpSlotAbWait -> "determines whether the character can wait, bracing for comat and potentially blocking the effects of some attacks." EqpSlotAbMoveItem -> "determines whether the character can pick up items and manage inventory." slotToDecorator :: EqpSlot -> Actor -> Int -> Text slotToDecorator eqpSlot b t = let tshow200 n = let n200 = min 200 $ max (-200) n in tshow n200 <> if n200 /= n then "$" else "" -- Some values can be negative, for others 0 is equivalent but shorter. tshowRadius r = if r == 0 then "0m" else tshow (r - 1) <> ".5m" tshowBlock k n = tshow200 $ n + if braced b then k else 0 showIntWith1 :: Int -> Text showIntWith1 k = let l = k `div` 10 x = k - l * 10 in tshow l <> if x == 0 then "" else "." <> tshow x in case eqpSlot of EqpSlotMiscBonus -> tshow t EqpSlotAddHurtMelee -> tshow200 t <> "%" EqpSlotAddArmorMelee -> "[" <> tshowBlock 50 t <> "%]" EqpSlotAddArmorRanged -> "{" <> tshowBlock 25 t <> "%}" EqpSlotAddMaxHP -> tshow $ max 0 t EqpSlotAddSpeed -> showIntWith1 (max minSpeed t) <> "m/s" EqpSlotAddSight -> let tmax = max 0 t tcapped = min (fromEnum $ bcalm b `div` (5 * oneM)) tmax in tshowRadius tcapped <+> if tcapped == tmax then "" else "(max" <+> tshowRadius tmax <> ")" EqpSlotLightSource -> tshowRadius (max 0 t) EqpSlotWeapon -> tshow t EqpSlotMiscAbility -> tshow t EqpSlotAbMove -> tshow t EqpSlotAbMelee -> tshow t EqpSlotAbDisplace -> tshow t EqpSlotAbAlter -> tshow t EqpSlotAbProject -> tshow t EqpSlotAbApply -> tshow t EqpSlotAddMaxCalm -> tshow $ max 0 t EqpSlotAddSmell -> tshowRadius (max 0 t) EqpSlotAddNocto -> tshowRadius (max 0 t) EqpSlotAddAggression -> tshow t EqpSlotAbWait -> tshow t EqpSlotAbMoveItem -> tshow t statSlots :: [EqpSlot] statSlots = [ EqpSlotAddHurtMelee , EqpSlotAddArmorMelee , EqpSlotAddArmorRanged , EqpSlotAddMaxHP , EqpSlotAddMaxCalm , EqpSlotAddSpeed , EqpSlotAddSight , EqpSlotAddSmell , EqpSlotLightSource , EqpSlotAddNocto -- WIP: , EqpSlotAddAggression , EqpSlotAbMove , EqpSlotAbMelee , EqpSlotAbDisplace , EqpSlotAbAlter , EqpSlotAbWait , EqpSlotAbMoveItem , EqpSlotAbProject , EqpSlotAbApply ] 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 kindAspectToSuffix :: Aspect -> Text kindAspectToSuffix aspect = case aspect of Timeout{} -> "" -- printed specially AddHurtMelee{} -> "" -- printed together with dice, even if dice is zero AddArmorMelee t -> "[" <> affixDice t <> "%]" AddArmorRanged t -> "{" <> affixDice t <> "%}" AddMaxHP t -> wrapInParens $ affixDice t <+> "HP" AddMaxCalm t -> wrapInParens $ affixDice t <+> "Calm" AddSpeed t -> wrapInParens $ affixDice t <+> "speed" AddSight t -> wrapInParens $ affixDice t <+> "sight" AddSmell t -> wrapInParens $ affixDice t <+> "smell" AddShine t -> wrapInParens $ affixDice t <+> "shine" AddNocto t -> wrapInParens $ affixDice t <+> "night vision" AddAggression t -> wrapInParens $ affixDice t <+> "aggression" AddAbility ab t -> wrapInParens $ affixDice t <+> tshow ab featureToSuff :: Feature -> Text featureToSuff feat = case feat of ELabel{} -> "" -- too late Fragile -> wrapInChevrons "fragile" Lobable -> wrapInChevrons "can be lobbed" Durable -> wrapInChevrons "durable" ToThrow tmod -> wrapInChevrons $ tmodToSuff "flies" tmod HideAs{} -> "" Equipable -> "" Meleeable -> "" Precious -> "" Tactic tactics -> "overrides tactics to" <+> tshow tactics Blast -> "" EqpSlot{} -> "" -- used in @slotToSentence@ instead Unique -> "" -- marked by capital letters in name Periodic -> "" -- printed specially MinorEffects -> "" -- cryptic override featureToSentence :: Feature -> Maybe Text featureToSentence feat = case feat of ELabel{} -> Nothing Fragile -> Nothing Lobable -> Nothing Durable -> Nothing ToThrow{} -> Nothing HideAs{} -> Nothing Equipable -> Nothing Meleeable -> Just "It is considered for melee strikes by default." Precious -> Just "It seems precious." Tactic{} -> Nothing Blast -> Nothing EqpSlot es -> Just $ slotToSentence es Unique -> Nothing Periodic -> Nothing MinorEffects -> Nothing affixBonus :: Int -> Text affixBonus p = case compare p 0 of EQ -> "0" LT -> tshow p GT -> "+" <> tshow p wrapInParens :: Text -> Text wrapInParens "" = "" wrapInParens t = "(" <> t <> ")" wrapInChevrons :: Text -> Text wrapInChevrons "" = "" wrapInChevrons t = "<" <> t <> ">" affixDice :: Dice.Dice -> Text affixDice d = maybe "+?" affixBonus $ Dice.reduceDice d LambdaHack-0.8.3.0/Game/LambdaHack/Client/UI/ItemDescription.hs0000644000000000000000000003720713315545734022051 0ustar0000000000000000-- | Descripitons of items. module Game.LambdaHack.Client.UI.ItemDescription ( partItem, partItemShort, partItemShortest, partItemHigh, partItemWs , partItemWsRanged, partItemShortAW, partItemMediumAW, partItemShortWownW , viewItem, itemDesc #ifdef EXPOSE_INTERNAL -- * Internal operations , show64With2, partItemN, textAllAE, partItemWsR #endif ) where import Prelude () import Game.LambdaHack.Common.Prelude import qualified Data.EnumMap.Strict as EM import Data.Int (Int64) import qualified Data.Text as T import qualified NLP.Miniutter.English as MU import Game.LambdaHack.Client.UI.EffectDescription import Game.LambdaHack.Client.UI.Overlay 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.Flavour import Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.ItemAspect as IA import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.Time import qualified Game.LambdaHack.Content.ItemKind as IK show64With2 :: Int64 -> Text show64With2 n = let k = 100 * n `div` oneM l = k `div` 100 x = k - l * 100 in tshow l <> if | x == 0 -> "" | x < 10 -> ".0" <> tshow x | otherwise -> "." <> tshow x -- | The part of speech describing the item parameterized by the number -- of effects/aspects to show. partItemN :: FactionId -> FactionDict -> Bool -> DetailLevel -> Int -> Time -> ItemFull -> ItemQuant -> (Bool, Bool, MU.Part, MU.Part) partItemN side factionD ranged detailLevel maxWordsToShow localTime itemFull@ItemFull{itemBase, itemKind, itemSuspect} (itemK, itemTimer) = let flav = flavourToName $ jflavour itemBase timeout = IA.aTimeout $ aspectRecordFull itemFull timeoutTurns = timeDeltaScale (Delta timeTurn) timeout temporary = not (null itemTimer) && timeout == 0 charging startT = timeShift startT timeoutTurns > localTime it1 = filter charging itemTimer lenCh = length it1 timer | lenCh == 0 || temporary = "" | itemK == 1 && lenCh == 1 = "(charging)" | itemK == lenCh = "(all charging)" | otherwise = "(" <> tshow lenCh <+> "charging)" skipRecharging = detailLevel <= DetailLow && lenCh >= itemK (effTsRaw, rangedDamage) = textAllAE detailLevel skipRecharging itemFull effTs = effTsRaw ++ if ranged then rangedDamage else [] lsource = case jfid itemBase of Just fid | IK.iname itemKind `elem` ["impressed"] -> ["by" <+> if fid == side then "us" else gname (factionD EM.! fid)] _ -> [] ts = lsource ++ take maxWordsToShow effTs ++ ["(...)" | length effTs > maxWordsToShow && maxWordsToShow > 1] ++ [timer | maxWordsToShow > 1] unique = IK.Unique `elem` IK.ifeature itemKind name | temporary = "temporarily" <+> IK.iname itemKind | itemSuspect = flav <+> IK.iname itemKind | otherwise = IK.iname itemKind capName = if unique then MU.Capitalize $ MU.Text name else MU.Text name in ( not (null lsource) || temporary , unique, capName, MU.Phrase $ map MU.Text ts ) textAllAE :: DetailLevel -> Bool -> ItemFull -> ([Text], [Text]) textAllAE detailLevel skipRecharging itemFull@ItemFull{itemKind, itemDisco} = let features | detailLevel >= DetailAll = map featureToSuff $ sort $ IK.ifeature itemKind | otherwise = [] aets = case itemDisco of ItemDiscoMean{} -> splitTry (IK.iaspects itemKind) -- faster than @aspectRecordToList@ of mean ItemDiscoFull iAspect -> splitTry (IA.aspectRecordToList iAspect) timeoutAspect :: IA.Aspect -> Bool timeoutAspect IA.Timeout{} = True timeoutAspect _ = False hurtMeleeAspect :: IA.Aspect -> Bool hurtMeleeAspect IA.AddHurtMelee{} = True hurtMeleeAspect _ = False elabel :: IK.Feature -> Bool elabel IK.ELabel{} = True elabel _ = False active = IK.goesIntoEqp itemKind splitAE :: DetailLevel -> [IA.Aspect] -> [Text] splitAE detLev aspects = let ppA = kindAspectToSuffix ppE = effectToSuffix detLev reduce_a = maybe "?" tshow . Dice.reduceDice periodic = IK.Periodic `elem` IK.ifeature itemKind mtimeout = find timeoutAspect aspects elab = case find elabel $ IK.ifeature itemKind of Just (IK.ELabel t) -> [t] _ -> [] -- Effects are not being sorted here, because they should fire -- in the order specified in content. restAs = sort aspects restEs | detLev >= DetailHigh || IK.MinorEffects `notElem` IK.ifeature itemKind = IK.ieffects itemKind | otherwise = [] aes = if active then map ppA restAs ++ map ppE restEs else map ppE restEs ++ map ppA restAs rechargingTs = T.intercalate " " $ filter (not . T.null) $ map ppE $ IK.stripRecharging restEs onSmashTs = T.intercalate " " $ filter (not . T.null) $ map ppE $ IK.stripOnSmash restEs durable = IK.Durable `elem` IK.ifeature itemKind fragile = IK.Fragile `elem` IK.ifeature itemKind periodicOrTimeout = if | skipRecharging || T.null rechargingTs -> "" | periodic -> case mtimeout of Nothing | durable && not fragile -> "(each turn:" <+> rechargingTs <> ")" Nothing -> "(each turn until gone:" <+> rechargingTs <> ")" Just (IA.Timeout t) -> "(every" <+> reduce_a t <> ":" <+> rechargingTs <> ")" _ -> error $ "" `showFailure` mtimeout | otherwise -> case mtimeout of Nothing -> "" Just (IA.Timeout t) -> "(timeout" <+> reduce_a t <> ":" <+> rechargingTs <> ")" _ -> error $ "" `showFailure` mtimeout onSmash = if T.null onSmashTs then "" else "(on smash:" <+> onSmashTs <> ")" damage = case find hurtMeleeAspect restAs of Just (IA.AddHurtMelee hurtMelee) -> (if IK.idamage itemKind == 0 then "0d0" else tshow (IK.idamage itemKind)) <> affixDice hurtMelee <> "%" _ -> if IK.idamage itemKind == 0 then "" else tshow (IK.idamage itemKind) in filter (/= "") $ elab ++ if detLev >= DetailHigh || detLev >= DetailMedium && null elab then [periodicOrTimeout] ++ [damage] ++ aes ++ [onSmash | detLev >= DetailAll] else [damage] splitTry ass = let splits = map (`splitAE` ass) [minBound..maxBound] splitsToTry = drop (fromEnum detailLevel) splits in case filter (/= []) splitsToTry of detNonEmpty : _ -> detNonEmpty [] -> [] IK.ThrowMod{IK.throwVelocity} = IK.getToThrow itemKind speed = speedFromWeight (IK.iweight itemKind) throwVelocity meanDmg = ceiling $ Dice.meanDice (IK.idamage itemKind) minDeltaHP = xM meanDmg `divUp` 100 aHurtMeleeOfItem = IA.aHurtMelee $ aspectRecordFull itemFull pmult = 100 + min 99 (max (-99) aHurtMeleeOfItem) prawDeltaHP = fromIntegral pmult * minDeltaHP pdeltaHP = modifyDamageBySpeed prawDeltaHP speed rangedDamage = if pdeltaHP == 0 then [] else ["{avg" <+> show64With2 pdeltaHP <+> "ranged}"] -- Note that avg melee damage would be too complex to display here, -- because in case of @MOwned@ the owner is different than leader, -- so the value would be different than when viewing the item. in (aets ++ features, rangedDamage) -- | The part of speech describing the item. partItem :: FactionId -> FactionDict -> Time -> ItemFull -> ItemQuant -> (Bool, Bool, MU.Part, MU.Part) partItem side factionD = partItemN side factionD False DetailMedium 4 partItemShort :: FactionId -> FactionDict -> Time -> ItemFull -> ItemQuant -> (Bool, Bool, MU.Part, MU.Part) partItemShort side factionD = partItemN side factionD False DetailLow 4 partItemShortest :: FactionId -> FactionDict -> Time -> ItemFull -> ItemQuant -> (Bool, Bool, MU.Part, MU.Part) partItemShortest side factionD = partItemN side factionD False DetailLow 0 partItemHigh :: FactionId -> FactionDict -> Time -> ItemFull -> ItemQuant -> (Bool, Bool, MU.Part, MU.Part) partItemHigh side factionD = partItemN side factionD False DetailAll 100 -- The @count@ can be different than @itemK@ in @ItemFull@, e.g., when picking -- a subset of items to drop. partItemWsR :: FactionId -> FactionDict -> Bool -> Int -> Time -> ItemFull -> ItemQuant -> (Bool, MU.Part) partItemWsR side factionD ranged count localTime itemFull@ItemFull{itemKind} kit = let (temporary, unique, name, stats) = partItemN side factionD ranged DetailMedium 4 localTime itemFull kit tmpCondition = IK.isTmpCondition itemKind in ( temporary , if | temporary && count == 1 -> MU.Phrase [name, stats] | temporary -> MU.Phrase [MU.Text $ tshow count <> "-fold", name, stats] | unique && count == 1 -> MU.Phrase ["the", name, stats] | tmpCondition -> MU.Phrase [name, stats] | otherwise -> MU.Phrase [MU.CarWs count name, stats] ) partItemWs :: FactionId -> FactionDict -> Int -> Time -> ItemFull -> ItemQuant -> (Bool, MU.Part) partItemWs side factionD = partItemWsR side factionD False partItemWsRanged :: FactionId -> FactionDict -> Int -> Time -> ItemFull -> ItemQuant -> (Bool, MU.Part) partItemWsRanged side factionD = partItemWsR side factionD True partItemShortAW :: FactionId -> FactionDict -> Time -> ItemFull -> ItemQuant -> MU.Part partItemShortAW side factionD localTime itemFull kit = let (_, unique, name, _) = partItemShort side factionD localTime itemFull kit in if unique then MU.Phrase ["the", name] else MU.AW name partItemMediumAW :: FactionId -> FactionDict -> Time -> ItemFull -> ItemQuant -> MU.Part partItemMediumAW side factionD localTime itemFull kit = let (_, unique, name, stats) = partItemN side factionD False DetailMedium 100 localTime itemFull kit in if unique then MU.Phrase ["the", name, stats] else MU.AW $ MU.Phrase [name, stats] partItemShortWownW :: FactionId -> FactionDict -> MU.Part -> Time -> ItemFull -> ItemQuant -> MU.Part partItemShortWownW side factionD partA localTime itemFull kit = let (_, _, name, _) = partItemShort side factionD localTime itemFull kit in MU.WownW partA name viewItem :: ItemFull -> Color.AttrCharW32 {-# INLINE viewItem #-} viewItem itemFull = Color.attrChar2ToW32 (flavourToColor $ jflavour $ itemBase itemFull) (IK.isymbol $ itemKind itemFull) itemDesc :: Bool -> FactionId -> FactionDict -> Int -> CStore -> Time -> ItemFull -> ItemQuant -> AttrLine itemDesc markParagraphs side factionD aHurtMeleeOfOwner store localTime itemFull@ItemFull{itemBase, itemKind, itemSuspect} kit = let (_, unique, name, stats) = partItemHigh side factionD localTime itemFull kit nstats = makePhrase [name, stats] IK.ThrowMod{IK.throwVelocity, IK.throwLinger} = IK.getToThrow itemKind speed = speedFromWeight (IK.iweight itemKind) throwVelocity range = rangeFromSpeedAndLinger speed throwLinger tspeed | IK.isTmpCondition itemKind = "" | speed < speedLimp = "When thrown, it drops at once." | speed < speedWalk = "When thrown, it travels only one meter and drops immediately." | otherwise = "When thrown, it flies with speed of" <+> tshow (fromSpeed speed `div` 10) <> if throwLinger /= 100 then " m/s and range" <+> tshow range <+> "m." else " m/s." tsuspect = ["You are unsure what it does." | itemSuspect] (desc, featureSentences, damageAnalysis) = let sentences = tsuspect ++ mapMaybe featureToSentence (IK.ifeature itemKind) aHurtMeleeOfItem = IA.aHurtMelee $ aspectRecordFull itemFull meanDmg = ceiling $ Dice.meanDice (IK.idamage itemKind) dmgAn = if meanDmg <= 0 then "" else let multRaw = aHurtMeleeOfOwner + if store `elem` [CEqp, COrgan] then 0 else aHurtMeleeOfItem mult = 100 + min 99 (max (-99) multRaw) minDeltaHP = xM meanDmg `divUp` 100 rawDeltaHP = fromIntegral mult * minDeltaHP pmult = 100 + min 99 (max (-99) aHurtMeleeOfItem) prawDeltaHP = fromIntegral pmult * minDeltaHP pdeltaHP = modifyDamageBySpeed prawDeltaHP speed mDeltaHP = modifyDamageBySpeed minDeltaHP speed in "Against defenceless targets you would inflict around" -- rounding and non-id items <+> tshow meanDmg <> "*" <> tshow mult <> "%" <> "=" <> show64With2 rawDeltaHP <+> "melee damage (min" <+> show64With2 minDeltaHP <> ") and" <+> tshow meanDmg <> "*" <> tshow pmult <> "%" <> "*" <> "speed^2" <> "/" <> tshow (fromSpeed speedThrust `divUp` 10) <> "^2" <> "=" <> show64With2 pdeltaHP <+> "ranged damage (min" <+> show64With2 mDeltaHP <> ") with it" <> if Dice.minDice (IK.idamage itemKind) == Dice.maxDice (IK.idamage itemKind) then "." else "on average." in (IK.idesc itemKind, T.intercalate " " sentences, tspeed <+> dmgAn) weight = IK.iweight itemKind (scaledWeight, unitWeight) | weight > 1000 = (tshow $ fromIntegral weight / (1000 :: Double), "kg") | otherwise = (tshow weight, "g") onLevel = "on level" <+> tshow (abs $ fromEnum $ jlid itemBase) <> "." discoFirst = (if unique then "Discovered" else "First seen") <+> onLevel whose fid = gname (factionD EM.! fid) sourceDesc = case jfid itemBase of Just fid | IK.isTmpCondition itemKind -> "Caused by" <+> (if fid == side then "us" else whose fid) <> ". First observed" <+> onLevel Just fid -> "Coming from" <+> whose fid <> "." <+> discoFirst _ -> discoFirst colorSymbol = viewItem itemFull blurb = ((" " <> nstats <> (if markParagraphs then ":\n\n" else ": ") <> desc <> (if markParagraphs && not (T.null desc) then "\n\n" else "")) <+> (if weight > 0 then makeSentence ["Weighs around", MU.Text scaledWeight <> unitWeight] else "")) <+> featureSentences <+> sourceDesc <+> damageAnalysis in colorSymbol : textToAL blurb LambdaHack-0.8.3.0/Game/LambdaHack/Client/UI/UIOptions.hs0000644000000000000000000001337413315545734020637 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} -- | UI client options. module Game.LambdaHack.Client.UI.UIOptions ( UIOptions(..), mkUIOptions, applyUIOptions #ifdef EXPOSE_INTERNAL -- * Internal operations , parseConfig #endif ) where import Prelude () import Game.LambdaHack.Common.Prelude import Control.DeepSeq import Data.Binary import qualified Data.Ini as Ini import qualified Data.Ini.Reader as Ini import qualified Data.Ini.Types as Ini import qualified Data.Map.Strict as M import Game.LambdaHack.Client.ClientOptions import GHC.Generics (Generic) import System.FilePath import Text.Read import Game.LambdaHack.Client.UI.HumanCmd import qualified Game.LambdaHack.Client.UI.Key as K import Game.LambdaHack.Common.File import Game.LambdaHack.Common.Kind import Game.LambdaHack.Common.Misc import Game.LambdaHack.Content.RuleKind -- | Options that affect the UI of the client. data UIOptions = UIOptions { -- commands uCommands :: [(K.KM, CmdTriple)] -- hero names , uHeroNames :: [(Int, (Text, Text))] -- ui , uVi :: Bool -- ^ the option for Vi keys takes precendence , uLaptop :: Bool -- ^ because the laptop keys are the default , uGtkFontFamily :: Text , uSdlFontFile :: Text , uSdlTtfSizeAdd :: Int , uSdlFonSizeAdd :: Int , uFontSize :: Int , uColorIsBold :: Bool , uHistoryMax :: Int , uMaxFps :: Int , uNoAnim :: Bool , uRunStopMsgs :: Bool , uhpWarningPercent :: Int -- ^ HP percent at which warning is emitted. , uCmdline :: [String] -- ^ Hardwired commandline arguments to process. } deriving (Show, Generic) instance NFData UIOptions instance Binary UIOptions parseConfig :: Ini.Config -> UIOptions parseConfig cfg = let uCommands = let mkCommand (ident, keydef) = case stripPrefix "Cmd_" ident of Just _ -> let (key, def) = read keydef in (K.mkKM key, def :: CmdTriple) Nothing -> error $ "wrong macro id" `showFailure` ident section = Ini.allItems "extra_commands" cfg in map mkCommand section uHeroNames = let toNumber (ident, nameAndPronoun) = case stripPrefix "HeroName_" ident of Just n -> (read n, read nameAndPronoun) Nothing -> error $ "wrong hero name id" `showFailure` 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 = error $ "config file access failed" `showFailure` (err, optionName, cfg) s = fromMaybe (lookupFail "") $ Ini.getOption "ui" optionName cfg in either lookupFail id $ readEither s uVi = getOption "movementViKeys_hjklyubn" -- The option for Vi keys takes precendence, -- because the laptop keys are the default. uLaptop = not uVi && getOption "movementLaptopKeys_uk8o79jl" uGtkFontFamily = getOption "gtkFontFamily" uSdlFontFile = getOption "sdlFontFile" uSdlTtfSizeAdd = getOption "sdlTtfSizeAdd" uSdlFonSizeAdd = getOption "sdlFonSizeAdd" uFontSize = getOption "fontSize" uColorIsBold = getOption "colorIsBold" uHistoryMax = getOption "historyMax" uMaxFps = max 1 $ getOption "maxFps" uNoAnim = getOption "noAnim" uRunStopMsgs = getOption "runStopMsgs" uhpWarningPercent = getOption "hpWarningPercent" uCmdline = words $ getOption "overrideCmdline" in UIOptions{..} -- | Read and parse UI config file. mkUIOptions :: COps -> Bool -> IO UIOptions mkUIOptions cops benchmark = do let stdRuleset = getStdRuleset cops cfgUIName = rcfgUIName stdRuleset sUIDefault = rcfgUIDefault stdRuleset cfgUIDefault = either (error . ("" `showFailure`)) id $ Ini.parse sUIDefault dataDir <- appDataDir let userPath = dataDir cfgUIName cfgUser <- if benchmark then return Ini.emptyConfig else do cpExists <- doesFileExist userPath if not cpExists then return Ini.emptyConfig else do sUser <- readFile userPath return $! either (error . ("" `showFailure`)) 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 -- | Modify client options with UI options. applyUIOptions :: COps -> UIOptions -> ClientOptions -> ClientOptions applyUIOptions cops uioptions soptions = let stdRuleset = getStdRuleset cops in (\opts -> opts {sgtkFontFamily = sgtkFontFamily opts `mplus` Just (uGtkFontFamily uioptions)}) . (\opts -> opts {sdlFontFile = sdlFontFile opts `mplus` Just (uSdlFontFile uioptions)}) . (\opts -> opts {sdlTtfSizeAdd = sdlTtfSizeAdd opts `mplus` Just (uSdlTtfSizeAdd uioptions)}) . (\opts -> opts {sdlFonSizeAdd = sdlFonSizeAdd opts `mplus` Just (uSdlFonSizeAdd uioptions)}) . (\opts -> opts {sfontSize = sfontSize opts `mplus` Just (uFontSize uioptions)}) . (\opts -> opts {scolorIsBold = scolorIsBold opts `mplus` Just (uColorIsBold uioptions)}) . (\opts -> opts {smaxFps = smaxFps opts `mplus` Just (uMaxFps uioptions)}) . (\opts -> opts {snoAnim = snoAnim opts `mplus` Just (uNoAnim uioptions)}) . (\opts -> opts {stitle = stitle opts `mplus` Just (rtitle stdRuleset)}) . (\opts -> opts {sfontDir = sfontDir opts `mplus` Just (rfontDir stdRuleset)}) $ soptions LambdaHack-0.8.3.0/Game/LambdaHack/Client/UI/Overlay.hs0000644000000000000000000000720713315545734020365 0ustar0000000000000000{-# LANGUAGE RankNTypes #-} -- | Screen overlays. module Game.LambdaHack.Client.UI.Overlay ( -- * AttrLine AttrLine, emptyAttrLine, textToAL, fgToAL, stringToAL, (<+:>) -- * Overlay , Overlay, IntOverlay , splitAttrLine, indentSplitAttrLine, glueLines, updateLines -- * Misc , ColorMode(..) #ifdef EXPOSE_INTERNAL -- * Internal operations , linesAttr, splitAttrPhrase #endif ) where import Prelude () import Game.LambdaHack.Common.Prelude import qualified Data.Text as T import qualified Game.LambdaHack.Common.Color as Color import Game.LambdaHack.Common.Point -- * AttrLine -- | Line of colourful text. type AttrLine = [Color.AttrCharW32] emptyAttrLine :: Int -> AttrLine emptyAttrLine xsize = replicate xsize Color.spaceAttrW32 textToAL :: Text -> AttrLine textToAL !t = let f c l = let !ac = Color.attrChar1ToW32 c in ac : l in T.foldr f [] t -- | Render line of text in the given foreground colour. fgToAL :: Color.Color -> Text -> AttrLine fgToAL !fg !t = let f c l = let !ac = Color.attrChar2ToW32 fg c in ac : l in T.foldr f [] t stringToAL :: String -> AttrLine stringToAL = map Color.attrChar1ToW32 infixr 6 <+:> -- matches Monoid.<> (<+:>) :: AttrLine -> AttrLine -> AttrLine (<+:>) [] l2 = l2 (<+:>) l1 [] = l1 (<+:>) l1 l2 = l1 ++ [Color.spaceAttrW32] ++ l2 -- * Overlay -- | A series of screen lines that either fit the width of the screen -- or are intended for truncation when displayed. The length of overlay -- may exceed the length of the screen, unlike in @SingleFrame@. -- An exception is lines generated from animation, which have to fit -- in either dimension. type Overlay = [AttrLine] -- | Sparse screen overlay representation where only the indicated rows -- are overlayed and the remaining rows are kept unchanged. type IntOverlay = [(Int, AttrLine)] -- | 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. splitAttrLine :: X -> AttrLine -> Overlay splitAttrLine w l = concatMap (splitAttrPhrase w . dropWhile (== Color.spaceAttrW32)) $ linesAttr l indentSplitAttrLine :: X -> AttrLine -> [AttrLine] indentSplitAttrLine w l = let ts = splitAttrLine (w - 1) l in case ts of [] -> [] hd : tl -> hd : map ([Color.spaceAttrW32] ++) tl linesAttr :: AttrLine -> Overlay linesAttr l | null l = [] | otherwise = h : if null t then [] else linesAttr (tail t) where (h, t) = span (/= Color.retAttrW32) l splitAttrPhrase :: X -> AttrLine -> Overlay splitAttrPhrase w xs | w >= length xs = [xs] -- no problem, everything fits | otherwise = let (pre, post) = splitAt w xs (ppre, ppost) = break (== Color.spaceAttrW32) $ reverse pre testPost = dropWhileEnd (== Color.spaceAttrW32) ppost in if null testPost then pre : splitAttrPhrase w post else reverse ppost : splitAttrPhrase w (reverse ppre ++ post) glueLines :: Overlay -> Overlay -> Overlay glueLines ov1 ov2 = reverse $ glue (reverse ov1) ov2 where glue [] l = l glue m [] = m glue (mh : mt) (lh : lt) = reverse lt ++ (mh <+:> lh) : mt -- @f@ should not enlarge the line beyond screen width. updateLines :: Int -> (AttrLine -> AttrLine) -> Overlay -> Overlay updateLines n f ov = let upd k (l : ls) = if k == 0 then f l : ls else l : upd (k - 1) ls upd _ [] = [] in upd n ov -- * Misc -- | Color mode for the display. data ColorMode = ColorFull -- ^ normal, with full colours | ColorBW -- ^ black and white only deriving Eq LambdaHack-0.8.3.0/Game/LambdaHack/Client/UI/MsgM.hs0000644000000000000000000000600413315545734017601 0ustar0000000000000000-- | Monadic operations on game messages. module Game.LambdaHack.Client.UI.MsgM ( msgAddDuplicate, msgAdd, promptAddDuplicate, promptAdd1, promptAdd0 , promptMainKeys, recordHistory ) where import Prelude () import Game.LambdaHack.Common.Prelude import qualified Game.LambdaHack.Client.UI.HumanCmd as HumanCmd import qualified Game.LambdaHack.Client.UI.Key as K import Game.LambdaHack.Client.UI.MonadClientUI import Game.LambdaHack.Client.UI.Msg import Game.LambdaHack.Client.UI.Overlay import Game.LambdaHack.Client.UI.SessionUI import Game.LambdaHack.Client.UI.UIOptions import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.MonadStateRead import Game.LambdaHack.Common.State -- | Add a message to the current report. msgAddDuplicate :: MonadClientUI m => Text -> m Bool msgAddDuplicate msg = do history <- getsSession shistory let (nhistory, duplicate) = addToReport history (toMsg $ textToAL msg) 1 modifySession $ \sess -> sess {shistory = nhistory} return duplicate -- | Add a message to the current report. Do not report if it was a duplicate. msgAdd :: MonadClientUI m => Text -> m () msgAdd = void <$> msgAddDuplicate -- | Add a prompt to the current report. promptAddDuplicate :: MonadClientUI m => Text -> Int -> m Bool promptAddDuplicate msg n = do history <- getsSession shistory let (nhistory, duplicate) = addToReport history (toPrompt $ textToAL msg) n modifySession $ \sess -> sess {shistory = nhistory} return duplicate -- | Add a prompt to the current report. Do not report if it was a duplicate. promptAdd1 :: MonadClientUI m => Text -> m () promptAdd1 = void <$> flip promptAddDuplicate 1 -- | Add a prompt to the current report with 0 copies for the purpose -- of collating cuplicates. Do not report if it was a duplicate. promptAdd0 :: MonadClientUI m => Text -> m () promptAdd0 = void <$> flip promptAddDuplicate 0 -- | Add a prompt with basic keys description. promptMainKeys :: MonadClientUI m => m () promptMainKeys = do revCmd <- revCmdMap let km = revCmd (K.mkChar '?') HumanCmd.Hint saimMode <- getsSession saimMode UIOptions{uVi, uLaptop} <- getsSession sUIOptions xhair <- getsSession sxhair -- The silly "uk8o79jl" ordering of keys is chosen to match "hjklyubn", -- which the usual way of writing them. let moveKeys | uVi = "keypad or hjklyubn" | uLaptop = "keypad or uk8o79jl" | otherwise = "keypad" moreHelp = "Press" <+> tshow km <+> "for help." keys | isNothing saimMode = "Explore with" <+> moveKeys <+> "keys or mouse." <+> moreHelp | otherwise = "Aim" <+> tgtKindDescription xhair <+> "with" <+> moveKeys <+> "keys or mouse." <+> moreHelp void $ promptAdd0 keys -- | Store new report in the history and archive old report. recordHistory :: MonadClientUI m => m () recordHistory = do time <- getsState stime history <- getsSession shistory modifySession $ \sess -> sess {shistory = archiveReport history time} LambdaHack-0.8.3.0/Game/LambdaHack/Client/UI/DrawM.hs0000644000000000000000000007071413315545734017761 0ustar0000000000000000-- {-# OPTIONS_GHC -fprof-auto #-} -- | Display game data on the screen using one of the available frontends -- (determined at compile time with cabal flags). module Game.LambdaHack.Client.UI.DrawM ( targetDescLeader, drawBaseFrame #ifdef EXPOSE_INTERNAL -- * Internal operations , targetDesc, targetDescXhair, drawFrameTerrain, drawFrameContent , drawFramePath, drawFrameActor, drawFrameExtra, drawFrameStatus , drawArenaStatus, drawLeaderStatus, drawLeaderDamage, drawSelected #endif ) where import Prelude () import Game.LambdaHack.Common.Prelude import Control.Monad.ST.Strict import qualified Data.Char as Char import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES import Data.Ord import qualified Data.Text as T import qualified Data.Vector.Unboxed as U import qualified Data.Vector.Unboxed.Mutable as VM import Data.Word (Word16) import Game.LambdaHack.Client.UI.UIOptions import GHC.Exts (inline) import qualified NLP.Miniutter.English as MU import Game.LambdaHack.Client.Bfs import Game.LambdaHack.Client.BfsM import Game.LambdaHack.Client.CommonM import Game.LambdaHack.Client.MonadClient import Game.LambdaHack.Client.State import Game.LambdaHack.Client.UI.ActorUI import Game.LambdaHack.Client.UI.Frame import Game.LambdaHack.Client.UI.ItemDescription import Game.LambdaHack.Client.UI.MonadClientUI import Game.LambdaHack.Client.UI.Overlay import Game.LambdaHack.Client.UI.SessionUI import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState import qualified Game.LambdaHack.Common.Color as Color import Game.LambdaHack.Common.ContentData import qualified Game.LambdaHack.Common.Dice as Dice import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.ItemAspect as IA import Game.LambdaHack.Common.Kind import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.MonadStateRead import Game.LambdaHack.Common.Perception import Game.LambdaHack.Common.Point import qualified Game.LambdaHack.Common.PointArray as PointArray import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile import Game.LambdaHack.Common.Time import Game.LambdaHack.Common.Vector import Game.LambdaHack.Content.CaveKind (cname) import qualified Game.LambdaHack.Content.ItemKind as IK import qualified Game.LambdaHack.Content.ModeKind as MK import Game.LambdaHack.Content.TileKind (TileKind, isUknownSpace) import qualified Game.LambdaHack.Content.TileKind as TK targetDesc :: MonadClientUI m => Maybe Target -> m (Maybe Text, Maybe Text) targetDesc mtarget = do arena <- getArenaUI lidV <- viewedLevelUI mleader <- getsClient sleader case mtarget of Just (TEnemy aid _) -> do side <- getsClient sside b <- getsState $ getActorBody aid bUI <- getsSession $ getActorUI aid ar <- getsState $ getActorAspect aid let percentage = 100 * bhp b `div` xM (max 5 $ IA.aMaxHP ar) chs n = "[" <> T.replicate n "*" <> T.replicate (4 - n) "_" <> "]" stars = chs $ fromEnum $ max 0 $ min 4 $ percentage `div` 20 hpIndicator = if bfid b == side then Nothing else Just stars return (Just $ bname bUI, hpIndicator) Just (TPoint tgoal lid p) -> case tgoal of TEnemyPos{} -> do let hotText = if lid == lidV && arena == lidV then "hot spot" <+> tshow p else "a hot spot on level" <+> tshow (abs $ fromEnum lid) return (Just hotText, Nothing) _ -> do -- the other goals can be invalidated by now anyway and it's -- better to say what there is rather than what there isn't pointedText <- if lid == lidV && arena == lidV then do bag <- getsState $ getFloorBag lid p case EM.assocs bag of [] -> return $! "exact spot" <+> tshow p [(iid, kit@(k, _))] -> do localTime <- getsState $ getLocalTime lid itemFull <- getsState $ itemToFull iid side <- getsClient sside factionD <- getsState sfactionD let (_, _, name, stats) = partItem side factionD localTime itemFull 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 (Just pointedText, Nothing) Just target@TVector{} -> case mleader of Nothing -> return (Just "a relative shift", Nothing) Just aid -> do tgtPos <- getsState $ aidTgtToPos aid lidV target let invalidMsg = "an invalid relative shift" validMsg p = "shift to" <+> tshow p return (Just $ maybe invalidMsg validMsg tgtPos, Nothing) Nothing -> return (Nothing, Nothing) targetDescLeader :: MonadClientUI m => ActorId -> m (Maybe Text, Maybe Text) targetDescLeader leader = do tgt <- getsClient $ getTarget leader targetDesc tgt targetDescXhair :: MonadClientUI m => m (Text, Maybe Text) targetDescXhair = do sxhair <- getsSession sxhair first fromJust <$> targetDesc (Just sxhair) drawFrameTerrain :: forall m. MonadClientUI m => LevelId -> m FrameForall drawFrameTerrain drawnLevelId = do COps{coTileSpeedup, cotile} <- getsState scops StateClient{smarkSuspect} <- getClient Level{lxsize, ltile=PointArray.Array{avector}} <- getLevel drawnLevelId totVisible <- totalVisible <$> getPerFid drawnLevelId let dis :: Int -> ContentId TileKind -> Color.AttrCharW32 {-# INLINE dis #-} dis pI tile = case okind cotile tile of TK.TileKind{tsymbol, tcolor, tcolor2} -> -- Passing @p0@ as arg in place of @pI@ is much more costly. let p0 :: Point {-# INLINE p0 #-} p0 = PointArray.punindex lxsize pI -- @smarkSuspect@ can be turned off easily, so let's overlay it -- over both visible and remembered tiles. fg :: Color.Color {-# INLINE fg #-} fg | smarkSuspect > 0 && Tile.isSuspect coTileSpeedup tile = Color.BrMagenta | smarkSuspect > 1 && Tile.isHideAs coTileSpeedup tile = Color.Magenta | ES.member p0 totVisible = tcolor | otherwise = tcolor2 in Color.attrChar2ToW32 fg tsymbol mapVT :: forall s. (Int -> ContentId TileKind -> Color.AttrCharW32) -> FrameST s {-# INLINE mapVT #-} mapVT f v = do let g :: Int -> Word16 -> ST s () g !pI !tile = do let w = Color.attrCharW32 $ f pI (ContentId tile) VM.write v (pI + lxsize) w U.imapM_ g avector upd :: FrameForall upd = FrameForall $ \v -> mapVT dis v -- should be eta-expanded; lazy return upd drawFrameContent :: forall m. MonadClientUI m => LevelId -> m FrameForall drawFrameContent drawnLevelId = do SessionUI{smarkSmell} <- getSession Level{lxsize, lsmell, ltime, lfloor} <- getLevel drawnLevelId itemToF <- getsState $ flip itemToFull let {-# INLINE viewItemBag #-} viewItemBag _ floorBag = case EM.toDescList floorBag of (iid, _kit) : _ -> viewItem $ itemToF iid [] -> error $ "lfloor not sparse" `showFailure` () viewSmell :: Point -> Time -> Color.AttrCharW32 {-# INLINE viewSmell #-} viewSmell p0 sml = let fg = toEnum $ fromEnum p0 `rem` 14 + 1 smlt = sml `timeDeltaToFrom` ltime in Color.attrChar2ToW32 fg (timeDeltaToDigit smellTimeout smlt) mapVAL :: forall a s. (Point -> a -> Color.AttrCharW32) -> [(Point, a)] -> FrameST s {-# INLINE mapVAL #-} mapVAL f l v = do let g :: (Point, a) -> ST s () g (!p0, !a0) = do let pI = PointArray.pindex lxsize p0 w = Color.attrCharW32 $ f p0 a0 VM.write v (pI + lxsize) w mapM_ g l upd :: FrameForall upd = FrameForall $ \v -> do mapVAL viewItemBag (EM.assocs lfloor) v when smarkSmell $ mapVAL viewSmell (filter ((> ltime) . snd) $ EM.assocs lsmell) v return upd drawFramePath :: forall m. MonadClientUI m => LevelId -> m FrameForall drawFramePath drawnLevelId = do SessionUI{saimMode} <- getSession if isNothing saimMode then return $! FrameForall $ \_ -> return () else do COps{coTileSpeedup} <- getsState scops StateClient{seps} <- getClient Level{lxsize, lysize, ltile=PointArray.Array{avector}} <- getLevel drawnLevelId totVisible <- totalVisible <$> getPerFid drawnLevelId mleader <- getsClient sleader xhairPosRaw <- xhairToPos let xhairPos = fromMaybe originPoint xhairPosRaw s <- getState bline <- case mleader of Just leader -> do Actor{bpos, blid} <- getsState $ getActorBody leader return $! if blid /= drawnLevelId then [] else fromMaybe [] $ bla lxsize lysize seps bpos xhairPos _ -> return [] mpath <- maybe (return Nothing) (\aid -> Just <$> do mtgtMPath <- getsClient $ EM.lookup aid . stargetD case mtgtMPath of Just TgtAndPath{tapPath=tapPath@AndPath{pathGoal}} | pathGoal == xhairPos -> return tapPath _ -> getCachePath aid xhairPos) mleader let lpath = if null bline then [] else maybe [] (\case NoPath -> [] AndPath {pathList} -> pathList) mpath xhairHere = find (\(_, m) -> xhairPos == bpos m) (inline actorAssocs (const True) drawnLevelId s) shiftedBTrajectory = case xhairHere of Just (_, Actor{btrajectory = Just p, bpos = prPos}) -> trajectoryToPath prPos (fst p) _ -> [] shiftedLine = if null shiftedBTrajectory then bline else shiftedBTrajectory acOnPathOrLine :: Char.Char -> Point -> ContentId TileKind -> Color.AttrCharW32 acOnPathOrLine !ch !p0 !tile = let fgOnPathOrLine = case ( ES.member p0 totVisible , Tile.isWalkable coTileSpeedup tile ) of _ | isUknownSpace tile -> Color.BrBlack _ | Tile.isSuspect coTileSpeedup tile -> Color.BrMagenta (True, True) -> Color.BrGreen (True, False) -> Color.BrRed (False, True) -> Color.Green (False, False) -> Color.Red in Color.attrChar2ToW32 fgOnPathOrLine ch mapVTL :: forall s. (Point -> ContentId TileKind -> Color.AttrCharW32) -> [Point] -> FrameST s mapVTL f l v = do let g :: Point -> ST s () g !p0 = do let pI = PointArray.pindex lxsize p0 tile = avector U.! pI w = Color.attrCharW32 $ f p0 (ContentId tile) VM.write v (pI + lxsize) w mapM_ g l upd :: FrameForall upd = FrameForall $ \v -> do mapVTL (acOnPathOrLine ';') lpath v mapVTL (acOnPathOrLine '*') shiftedLine v -- overwrites path return upd drawFrameActor :: forall m. MonadClientUI m => LevelId -> m FrameForall drawFrameActor drawnLevelId = do SessionUI{sactorUI, sselected, sUIOptions} <- getSession Level{lxsize, lactor} <- getLevel drawnLevelId side <- getsClient sside mleader <- getsClient sleader s <- getState let {-# INLINE viewActor #-} viewActor _ as = case as of aid : _ -> let Actor{bhp, bproj, bfid, btrunk} = getActorBody aid s ActorUI{bsymbol, bcolor} = sactorUI EM.! aid Item{jfid} = getItemBody btrunk s symbol | bhp > 0 || bproj = bsymbol | otherwise = '%' dominated = maybe False (/= bfid) jfid bg = if bproj then Color.HighlightNone else case mleader of Just leader | aid == leader -> Color.HighlightRed _ -> if | aid `ES.member` sselected -> Color.HighlightBlue | dominated -> if bfid == side -- dominated by us then Color.HighlightWhite else Color.HighlightMagenta | otherwise -> Color.HighlightNone fg | bfid /= side || bproj || bhp <= 0 = bcolor | otherwise = let (hpCheckWarning, calmCheckWarning) = checkWarnings sUIOptions aid s in if hpCheckWarning || calmCheckWarning then Color.Red else bcolor in Color.attrCharToW32 $ Color.AttrChar Color.Attr{..} symbol [] -> error $ "lactor not sparse" `showFailure` () mapVAL :: forall a s. (Point -> a -> Color.AttrCharW32) -> [(Point, a)] -> FrameST s {-# INLINE mapVAL #-} mapVAL f l v = do let g :: (Point, a) -> ST s () g (!p0, !a0) = do let pI = PointArray.pindex lxsize p0 w = Color.attrCharW32 $ f p0 a0 VM.write v (pI + lxsize) w mapM_ g l upd :: FrameForall upd = FrameForall $ \v -> mapVAL viewActor (EM.assocs lactor) v return upd drawFrameExtra :: forall m. MonadClientUI m => ColorMode -> LevelId -> m FrameForall drawFrameExtra dm drawnLevelId = do SessionUI{saimMode, smarkVision} <- getSession Level{lxsize, lysize} <- getLevel drawnLevelId totVisible <- totalVisible <$> getPerFid drawnLevelId mxhairPos <- xhairToPos mtgtPos <- do mleader <- getsClient sleader case mleader of Nothing -> return Nothing Just leader -> do mtgt <- getsClient $ getTarget leader case mtgt of Nothing -> return Nothing Just tgt -> getsState $ aidTgtToPos leader drawnLevelId tgt let visionMarks = if smarkVision then map (PointArray.pindex lxsize) $ ES.toList totVisible else [] backlightVision :: Color.AttrChar -> Color.AttrChar backlightVision ac = case ac of Color.AttrChar (Color.Attr fg _) ch -> Color.AttrChar (Color.Attr fg Color.HighlightGrey) ch writeSquare !hi (Color.AttrChar (Color.Attr fg bg) ch) = let hiUnlessLeader | bg == Color.HighlightRed = bg | otherwise = hi in Color.AttrChar (Color.Attr fg hiUnlessLeader) ch turnBW (Color.AttrChar _ ch) = Color.AttrChar Color.defAttr ch mapVL :: forall s. (Color.AttrChar -> Color.AttrChar) -> [Int] -> FrameST s mapVL f l v = do let g :: Int -> ST s () g !pI = do w0 <- VM.read v (pI + lxsize) let w = Color.attrCharW32 . Color.attrCharToW32 . f . Color.attrCharFromW32 . Color.AttrCharW32 $ w0 VM.write v (pI + lxsize) w mapM_ g l lDungeon = [0..lxsize * lysize - 1] upd :: FrameForall upd = FrameForall $ \v -> do when (isJust saimMode) $ mapVL backlightVision visionMarks v case mtgtPos of Nothing -> return () Just p -> mapVL (writeSquare Color.HighlightGrey) [PointArray.pindex lxsize p] v case mxhairPos of -- overwrites target Nothing -> return () Just p -> mapVL (writeSquare Color.HighlightYellow) [PointArray.pindex lxsize p] v when (dm == ColorBW) $ mapVL turnBW lDungeon v return upd drawFrameStatus :: MonadClientUI m => LevelId -> m AttrLine drawFrameStatus drawnLevelId = do cops <- getsState scops SessionUI{sselected, saimMode, swaitTimes, sitemSel} <- getSession mleader <- getsClient sleader xhairPos <- xhairToPos tgtPos <- leaderTgtToPos mbfs <- maybe (return Nothing) (\aid -> Just <$> getCacheBfs aid) mleader (mtgtDesc, mtargetHP) <- maybe (return (Nothing, Nothing)) targetDescLeader mleader (xhairDesc, mxhairHP) <- targetDescXhair lvl <- getLevel drawnLevelId (mblid, mbpos, mbodyUI) <- case mleader of Just leader -> do Actor{bpos, blid} <- getsState $ getActorBody leader bodyUI <- getsSession $ getActorUI leader return (Just blid, Just bpos, Just bodyUI) Nothing -> return (Nothing, Nothing, Nothing) let widthX = 80 widthTgt = 39 widthStats = widthX - widthTgt - 1 arenaStatus = drawArenaStatus cops lvl widthStats displayPathText mp mt = let (plen, llen) = case (mp, mbfs, 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 xhairPos mxhairHP trimTgtDesc n t = assert (not (T.null t) && n > 2 `blame` (t, n)) $ 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 xhairText = let n = widthTgt - T.length pathCsr - 8 in (if isJust saimMode then "x-hair>" else "X-hair:") <+> trimTgtDesc n xhairDesc xhairGap = emptyAttrLine (widthTgt - T.length pathCsr - T.length xhairText) xhairStatus = textToAL xhairText ++ xhairGap ++ textToAL pathCsr leaderStatusWidth = 23 leaderStatus <- drawLeaderStatus swaitTimes (selectedStatusWidth, selectedStatus) <- drawSelected drawnLevelId (widthStats - leaderStatusWidth) sselected damageStatus <- drawLeaderDamage (widthStats - leaderStatusWidth - selectedStatusWidth) side <- getsClient sside fact <- getsState $ (EM.! side) . sfactionD let statusGap = emptyAttrLine (widthStats - leaderStatusWidth - selectedStatusWidth - length damageStatus) tgtOrItem n = do let fallback = if MK.fleaderMode (gplayer fact) == MK.LeaderNull then "This faction never picks a leader" else "Waiting for a team member to spawn" leaderName = maybe fallback (\body -> "Leader:" <+> trimTgtDesc n (bname body)) mbodyUI tgtBlurb = maybe leaderName (\t -> "Target:" <+> trimTgtDesc n t) mtgtDesc case (sitemSel, mleader) of (Just (iid, fromCStore, _), Just leader) -> do b <- getsState $ getActorBody leader bag <- getsState $ getBodyStoreBag b fromCStore case iid `EM.lookup` bag of Nothing -> return $! tgtBlurb Just kit@(k, _) -> do localTime <- getsState $ getLocalTime (blid b) itemFull <- getsState $ itemToFull iid factionD <- getsState sfactionD let (_, _, name, stats) = partItem (bfid b) factionD localTime itemFull kit t = makePhrase $ if k == 1 then [name, stats] -- "a sword" too wordy else [MU.CarWs k name, stats] return $! "Item:" <+> trimTgtDesc n t _ -> return $! tgtBlurb -- The indicators must fit, they are the actual information. pathTgt = displayPathText tgtPos mtargetHP targetText <- tgtOrItem $ widthTgt - T.length pathTgt - 8 let targetGap = emptyAttrLine (widthTgt - T.length pathTgt - T.length targetText) targetStatus = textToAL targetText ++ targetGap ++ textToAL pathTgt return $! arenaStatus <+:> xhairStatus <> selectedStatus ++ statusGap ++ damageStatus ++ leaderStatus <+:> targetStatus -- | Draw the whole screen: level map and status area. drawBaseFrame :: MonadClientUI m => ColorMode -> LevelId -> m FrameForall drawBaseFrame dm drawnLevelId = do Level{lxsize, lysize} <- getLevel drawnLevelId updTerrain <- drawFrameTerrain drawnLevelId updContent <- drawFrameContent drawnLevelId updPath <- drawFramePath drawnLevelId updActor <- drawFrameActor drawnLevelId updExtra <- drawFrameExtra dm drawnLevelId frameStatus <- drawFrameStatus drawnLevelId let !_A = assert (length frameStatus == 2 * lxsize `blame` map Color.charFromW32 frameStatus) () upd = FrameForall $ \v -> do unFrameForall updTerrain v unFrameForall updContent v unFrameForall updPath v unFrameForall updActor v unFrameForall updExtra v unFrameForall (writeLine (lxsize * (lysize + 1)) frameStatus) v return upd -- Comfortably accomodates 3-digit level numbers and 25-character -- level descriptions (currently enforced max). drawArenaStatus :: COps -> Level -> Int -> AttrLine drawArenaStatus COps{cocave} Level{lkind, ldepth=Dice.AbsDepth ld, lseen, lexpl} width = let ck = okind cocave lkind seenN = 100 * lseen `div` max 1 lexpl seenTxt | seenN >= 100 = "all" | otherwise = T.justifyLeft 3 ' ' (tshow seenN <> "%") lvlN = T.justifyLeft 2 ' ' (tshow ld) seenStatus = "[" <> seenTxt <+> "seen]" in textToAL $ T.justifyLeft width ' ' $ T.take 29 (lvlN <+> T.justifyLeft 26 ' ' (cname ck)) <+> seenStatus checkWarnings :: UIOptions -> ActorId -> State -> (Bool, Bool) checkWarnings UIOptions{uhpWarningPercent} leader s = let b = getActorBody leader s ar = getActorAspect leader s isImpression iid = maybe False (> 0) $ lookup "impressed" $ IK.ifreq $ getIidKind iid s isImpressed = any isImpression $ EM.keys $ borgan b hpCheckWarning = bhp b <= xM (uhpWarningPercent * IA.aMaxHP ar `div` 100) calmCheckWarning = bcalm b <= xM (uhpWarningPercent * IA.aMaxCalm ar `div` 100) && isImpressed in (hpCheckWarning, calmCheckWarning) drawLeaderStatus :: MonadClientUI m => Int -> m AttrLine drawLeaderStatus waitT = do let calmHeaderText = "Calm" hpHeaderText = "HP" sUIOptions <- getsSession sUIOptions mleader <- getsClient sleader case mleader of Just leader -> do b <- getsState $ getActorBody leader ar <- getsState $ getActorAspect leader (hpCheckWarning, calmCheckWarning) <- getsState $ checkWarnings sUIOptions leader bdark <- getsState $ \s -> not (actorInAmbient b s) let showTrunc x = let t = show x in if length t > 3 then if x > 0 then "***" else "---" else t -- This is a valuable feedback for the otherwise hard to observe -- 'wait' command. slashes = ["/", "|", "\\", "|"] slashPick = slashes !! (max 0 waitT `mod` length slashes) addColor c = map (Color.attrChar2ToW32 c) checkDelta ResDelta{..} | fst resCurrentTurn < 0 || fst resPreviousTurn < 0 = addColor Color.BrRed -- alarming news have priority | snd resCurrentTurn > 0 || snd resPreviousTurn > 0 = addColor Color.BrGreen | otherwise = stringToAL -- only if nothing at all noteworthy calmAddAttr = checkDelta $ bcalmDelta b -- We only show ambient light, because in fact client can't tell -- if a tile is lit, because it it's seen it may be due to ambient -- or dynamic light or due to infravision. darkPick | bdark = "." | otherwise = ":" calmHeader = calmAddAttr $ calmHeaderText <> darkPick calmText = showTrunc (bcalm b `divUp` oneM) <> (if bdark || not (braced b) then slashPick else "/") <> showTrunc (max 0 $ IA.aMaxCalm ar) bracePick | braced b = "}" | otherwise = ":" hpAddAttr = checkDelta $ bhpDelta b hpHeader = hpAddAttr $ hpHeaderText <> bracePick hpText = showTrunc (bhp b `divUp` oneM) <> (if braced b || not bdark then slashPick else "/") <> showTrunc (max 0 $ IA.aMaxHP ar) justifyRight n t = replicate (n - length t) ' ' ++ t colorWarning w = if w then addColor Color.Red else stringToAL return $! calmHeader <> colorWarning calmCheckWarning (justifyRight 7 calmText) <+:> hpHeader <> colorWarning hpCheckWarning (justifyRight 7 hpText) Nothing -> return $! stringToAL (calmHeaderText ++ ": --/--") <+:> stringToAL (hpHeaderText <> ": --/--") drawLeaderDamage :: MonadClientUI m => Int -> m AttrLine drawLeaderDamage width = do mleader <- getsClient sleader (tdice, tbonus, cbonus) <- case mleader of Just leader -> do kitAssRaw <- getsState $ kitAssocs leader [CEqp, COrgan] actorSk <- leaderSkillsClientUI actorAspect <- getsState sactorAspect let kitAssOnlyWeapons = filter (IK.isMelee . itemKind . fst . snd) kitAssRaw strongest <- pickWeaponM Nothing kitAssOnlyWeapons actorSk leader let damage = case strongest of [] -> ("0", "", Color.White) (_, (_, (itemFull, _))) : _ -> let tdice = show $ IK.idamage $ itemKind itemFull bonusRaw = IA.aHurtMelee $ actorAspect EM.! leader bonus = min 200 $ max (-200) bonusRaw unknownBonus = unknownMeleeBonus $ map (fst . snd) kitAssRaw tbonus = if bonus == 0 then if unknownBonus then "+?" else "" else (if bonus > 0 then "+" else "") <> show bonus <> (if bonus /= bonusRaw then "$" else "") <> if unknownBonus then "%?" else "%" tmpBonus = tmpMeleeBonus $ map snd kitAssRaw cbonus = case compare tmpBonus 0 of EQ -> Color.White GT -> Color.Green LT -> Color.Red in (tdice, tbonus, cbonus) return $! damage Nothing -> return ("", "", Color.White) let addColorDice = map (Color.attrChar2ToW32 Color.BrCyan) addColorBonus = map (Color.attrChar2ToW32 cbonus) return $! if null tdice || length tdice + length tbonus >= width then [] else addColorDice tdice ++ addColorBonus tbonus ++ [Color.spaceAttrW32] drawSelected :: MonadClientUI m => LevelId -> Int -> ES.EnumSet ActorId -> m (Int, AttrLine) drawSelected drawnLevelId width selected = do mleader <- getsClient sleader side <- getsClient sside sactorUI <- getsSession sactorUI ours <- getsState $ filter (not . bproj . snd) . inline actorAssocs (== side) drawnLevelId let oursUI = map (\(aid, b) -> (aid, b, sactorUI EM.! aid)) ours viewOurs (aid, Actor{bhp}, ActorUI{bsymbol, bcolor}) = let bg = if | mleader == Just aid -> Color.HighlightRed | ES.member aid selected -> Color.HighlightBlue | otherwise -> Color.HighlightNone sattr = Color.Attr {Color.fg = bcolor, bg} in Color.attrCharToW32 $ Color.AttrChar sattr $ if bhp > 0 then bsymbol else '%' maxViewed = width - 2 len = length oursUI star = let fg = case ES.size selected of 0 -> Color.BrBlack n | n == len -> Color.BrWhite _ -> Color.defFG char = if len > maxViewed then '$' else '*' in Color.attrChar2ToW32 fg char viewed = map viewOurs $ take maxViewed $ sortBy (comparing keySelected) oursUI return (min width (len + 2), [star] ++ viewed ++ [Color.spaceAttrW32]) LambdaHack-0.8.3.0/Game/LambdaHack/Client/UI/ActorUI.hs0000644000000000000000000000657013315545734020254 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} -- | UI aspects of actors. module Game.LambdaHack.Client.UI.ActorUI ( ActorUI(..), ActorDictUI , keySelected, partActor, partPronoun , ppContainer, ppCStore, ppCStoreIn, ppCStoreWownW , ppContainerWownW, verbCStore, tryFindActor, tryFindHeroK ) where import Prelude () import Game.LambdaHack.Common.Prelude import Data.Binary import qualified Data.Char as Char import qualified Data.EnumMap.Strict as EM import GHC.Generics (Generic) import qualified NLP.Miniutter.English as MU import Game.LambdaHack.Common.Actor import qualified Game.LambdaHack.Common.Color as Color import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.State data ActorUI = ActorUI { bsymbol :: Char -- ^ individual map symbol , bname :: Text -- ^ individual name , bpronoun :: Text -- ^ individual pronoun , bcolor :: Color.Color -- ^ individual map color } deriving (Show, Eq, Generic) instance Binary ActorUI type ActorDictUI = EM.EnumMap ActorId ActorUI keySelected :: (ActorId, Actor, ActorUI) -> (Bool, Bool, Char, Color.Color, ActorId) keySelected (aid, Actor{bhp}, ActorUI{bsymbol, bcolor}) = (bhp > 0, bsymbol /= '@', bsymbol, bcolor, aid) -- | The part of speech describing the actor. partActor :: ActorUI -> MU.Part partActor b = MU.Text $ bname b -- | The part of speech containing the actor pronoun. partPronoun :: ActorUI -> MU.Part partPronoun b = MU.Text $ bpronoun b ppContainer :: Container -> Text ppContainer CFloor{} = "nearby" ppContainer CEmbed{} = "embedded nearby" ppContainer (CActor _ cstore) = ppCStoreIn cstore ppContainer c@CTrunk{} = error $ "" `showFailure` c ppCStore :: CStore -> (Text, Text) ppCStore CGround = ("on", "the ground") ppCStore COrgan = ("in", "body") 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 ppCStoreWownW :: Bool -> CStore -> MU.Part -> [MU.Part] ppCStoreWownW addPrepositions store owner = let (preposition, noun) = ppCStore store prep = [MU.Text preposition | addPrepositions] in prep ++ case store of CGround -> [MU.Text noun, "under", owner] CSha -> [MU.Text noun] _ -> [MU.WownW owner (MU.Text noun) ] ppContainerWownW :: (ActorId -> MU.Part) -> Bool -> Container -> [MU.Part] ppContainerWownW ownerFun addPrepositions c = case c of CFloor{} -> ["nearby"] CEmbed{} -> ["embedded nearby"] CActor aid store -> let owner = ownerFun aid in ppCStoreWownW addPrepositions store owner CTrunk{} -> error $ "" `showFailure` c verbCStore :: CStore -> Text verbCStore CGround = "drop" verbCStore COrgan = "implant" verbCStore CEqp = "equip" verbCStore CInv = "pack" verbCStore CSha = "stash" tryFindActor :: State -> (ActorId -> Actor -> Bool) -> Maybe (ActorId, Actor) tryFindActor s p = find (uncurry p) $ EM.assocs $ sactorD s tryFindHeroK :: ActorDictUI -> FactionId -> Int -> State -> Maybe (ActorId, Actor) tryFindHeroK d fid k s = let c | k == 0 = '@' | k > 0 && k < 10 = Char.intToDigit k | otherwise = ' ' -- no hero with such symbol in tryFindActor s (\aid body -> maybe False ((== c) . bsymbol) (EM.lookup aid d) && bfid body == fid) LambdaHack-0.8.3.0/Game/LambdaHack/Client/UI/HandleHumanM.hs0000644000000000000000000001413113315545734021237 0ustar0000000000000000-- | Semantics of human player commands. module Game.LambdaHack.Client.UI.HandleHumanM ( cmdHumanSem #ifdef EXPOSE_INTERNAL -- * Internal operations , noRemoteHumanCmd, cmdAction, addNoError #endif ) where import Prelude () import Game.LambdaHack.Common.Prelude import Game.LambdaHack.Client.Request import Game.LambdaHack.Client.UI.HandleHelperM import Game.LambdaHack.Client.UI.HandleHumanGlobalM import Game.LambdaHack.Client.UI.HandleHumanLocalM import Game.LambdaHack.Client.UI.HumanCmd import Game.LambdaHack.Client.UI.MonadClientUI -- | The semantics of human player commands in terms of the client monad. -- -- Some time cosuming commands are enabled even in aiming mode, but cannot be -- invoked in aiming mode on a remote level (level different than -- the level of the leader), which is caught here. cmdHumanSem :: MonadClientUI m => HumanCmd -> m (Either MError ReqUI) cmdHumanSem cmd = if noRemoteHumanCmd cmd then do -- If in aiming mode, check if the current level is the same -- as player level and refuse performing the action otherwise. arena <- getArenaUI lidV <- viewedLevelUI if arena /= lidV then weaveJust <$> failWith "command disabled on a remote level, press ESC to switch back" else cmdAction cmd else cmdAction cmd -- | Commands that are forbidden on a remote level, because they -- would usually take time when invoked on one, but not necessarily do -- what the player expects. Note that some commands that normally take time -- are not included, because they don't take time in aiming mode -- or their individual sanity conditions include a remote level check. noRemoteHumanCmd :: HumanCmd -> Bool noRemoteHumanCmd cmd = case cmd of Wait -> True Wait10 -> True MoveItem{} -> True Apply{} -> True AlterDir{} -> True AlterWithPointer{} -> True MoveOnceToXhair -> True RunOnceToXhair -> True ContinueToXhair -> True _ -> False cmdAction :: MonadClientUI m => HumanCmd -> m (Either MError ReqUI) cmdAction cmd = case cmd of Macro kms -> addNoError $ macroHuman kms ByArea l -> byAreaHuman cmdAction l ByAimMode{..} -> byAimModeHuman (cmdAction exploration) (cmdAction aiming) ComposeIfLocal cmd1 cmd2 -> composeIfLocalHuman (cmdAction cmd1) (cmdAction cmd2) ComposeUnlessError cmd1 cmd2 -> composeUnlessErrorHuman (cmdAction cmd1) (cmdAction cmd2) Compose2ndLocal cmd1 cmd2 -> compose2ndLocalHuman (cmdAction cmd1) (cmdAction cmd2) LoopOnNothing cmd1 -> loopOnNothingHuman (cmdAction cmd1) ExecuteIfClear cmd1 -> executeIfClearHuman (cmdAction cmd1) Wait -> weaveJust <$> (ReqUITimed <$$> waitHuman) Wait10 -> weaveJust <$> (ReqUITimed <$$> waitHuman10) MoveDir v -> weaveJust <$> (ReqUITimed <$$> moveRunHuman True True False False v) RunDir v -> weaveJust <$> (ReqUITimed <$$> moveRunHuman True True True True v) RunOnceAhead -> ReqUITimed <$$> runOnceAheadHuman MoveOnceToXhair -> weaveJust <$> (ReqUITimed <$$> moveOnceToXhairHuman) RunOnceToXhair -> weaveJust <$> (ReqUITimed <$$> runOnceToXhairHuman) ContinueToXhair -> weaveJust <$> (ReqUITimed <$$> continueToXhairHuman) MoveItem cLegalRaw toCStore mverb auto -> weaveJust <$> (ReqUITimed <$$> moveItemHuman cLegalRaw toCStore mverb auto) Project -> weaveJust <$> (ReqUITimed <$$> projectHuman) Apply -> weaveJust <$> (ReqUITimed <$$> applyHuman) AlterDir ts -> weaveJust <$> (ReqUITimed <$$> alterDirHuman ts) AlterWithPointer ts -> weaveJust <$> (ReqUITimed <$$> alterWithPointerHuman ts) Help -> helpHuman cmdAction Hint -> hintHuman cmdAction ItemMenu -> itemMenuHuman cmdAction ChooseItemMenu dialogMode -> chooseItemMenuHuman cmdAction dialogMode MainMenu -> mainMenuHuman cmdAction Dashboard -> dashboardHuman cmdAction GameDifficultyIncr -> gameDifficultyIncr >> challengesMenuHuman cmdAction GameWolfToggle -> gameWolfToggle >> challengesMenuHuman cmdAction GameFishToggle -> gameFishToggle >> challengesMenuHuman cmdAction GameScenarioIncr -> gameScenarioIncr >> mainMenuHuman cmdAction GameRestart -> weaveJust <$> gameRestartHuman GameExit -> weaveJust <$> fmap Right gameExitHuman GameSave -> weaveJust <$> fmap Right gameSaveHuman Tactic -> weaveJust <$> tacticHuman Automate -> weaveJust <$> automateHuman SortSlots -> addNoError sortSlotsHuman ChooseItem dialogMode -> Left <$> chooseItemHuman dialogMode ChooseItemProject ts -> Left <$> chooseItemProjectHuman ts ChooseItemApply ts -> Left <$> chooseItemApplyHuman ts PickLeader k -> Left <$> pickLeaderHuman k PickLeaderWithPointer -> Left <$> pickLeaderWithPointerHuman MemberCycle -> Left <$> memberCycleHuman MemberBack -> Left <$> memberBackHuman SelectActor -> addNoError selectActorHuman SelectNone -> addNoError selectNoneHuman SelectWithPointer -> Left <$> selectWithPointerHuman Repeat n -> addNoError $ repeatHuman n Record -> addNoError recordHuman History -> addNoError historyHuman MarkVision -> markVisionHuman >> settingsMenuHuman cmdAction MarkSmell -> markSmellHuman >> settingsMenuHuman cmdAction MarkSuspect -> markSuspectHuman >> settingsMenuHuman cmdAction SettingsMenu -> settingsMenuHuman cmdAction ChallengesMenu -> challengesMenuHuman cmdAction PrintScreen -> addNoError printScreenHuman Cancel -> addNoError cancelHuman Accept -> addNoError acceptHuman TgtClear -> addNoError tgtClearHuman ItemClear -> addNoError itemClearHuman MoveXhair v k -> Left <$> moveXhairHuman v k AimTgt -> Left <$> aimTgtHuman AimFloor -> addNoError aimFloorHuman AimEnemy -> addNoError aimEnemyHuman AimItem -> addNoError aimItemHuman AimAscend k -> Left <$> aimAscendHuman k EpsIncr b -> addNoError $ epsIncrHuman b XhairUnknown -> Left <$> xhairUnknownHuman XhairItem -> Left <$> xhairItemHuman XhairStair up -> Left <$> xhairStairHuman up XhairPointerFloor -> addNoError xhairPointerFloorHuman XhairPointerEnemy -> addNoError xhairPointerEnemyHuman AimPointerFloor -> addNoError aimPointerFloorHuman AimPointerEnemy -> addNoError aimPointerEnemyHuman addNoError :: Monad m => m () -> m (Either MError ReqUI) addNoError cmdCli = cmdCli >> return (Left Nothing) LambdaHack-0.8.3.0/Game/LambdaHack/Client/UI/InventoryM.hs0000644000000000000000000005350213315545734021055 0ustar0000000000000000-- | UI of inventory management. module Game.LambdaHack.Client.UI.InventoryM ( Suitability(..) , getFull, getGroupItem, getStoreItem , ppItemDialogMode, ppItemDialogModeFrom ) where import Prelude () import Game.LambdaHack.Common.Prelude import qualified Data.Char as Char import Data.Either import qualified Data.EnumMap.Strict as EM import qualified Data.Text as T import Data.Tuple (swap) import qualified NLP.Miniutter.English as MU import Game.LambdaHack.Client.MonadClient import Game.LambdaHack.Client.State import Game.LambdaHack.Client.UI.ActorUI import Game.LambdaHack.Client.UI.HandleHelperM import Game.LambdaHack.Client.UI.HumanCmd import Game.LambdaHack.Client.UI.ItemSlot import qualified Game.LambdaHack.Client.UI.Key as K import Game.LambdaHack.Client.UI.MonadClientUI import Game.LambdaHack.Client.UI.MsgM import Game.LambdaHack.Client.UI.Overlay import Game.LambdaHack.Client.UI.SessionUI import Game.LambdaHack.Client.UI.Slideshow import Game.LambdaHack.Client.UI.SlideshowM import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.ItemAspect as IA import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.MonadStateRead import Game.LambdaHack.Common.ReqFailure import Game.LambdaHack.Common.State data ItemDialogState = ISuitable | IAll deriving (Show, Eq) ppItemDialogMode :: ItemDialogMode -> (Text, Text) ppItemDialogMode (MStore cstore) = ppCStore cstore ppItemDialogMode MOrgans = ("in", "body") ppItemDialogMode MOwned = ("in", "our possession") ppItemDialogMode MStats = ("among", "strengths") ppItemDialogMode (MLore slore) = ("among", ppSLore slore <+> "lore") ppItemDialogModeIn :: ItemDialogMode -> Text ppItemDialogModeIn c = let (tIn, t) = ppItemDialogMode c in tIn <+> t ppItemDialogModeFrom :: ItemDialogMode -> Text ppItemDialogModeFrom c = let (_tIn, t) = ppItemDialogMode c in "from" <+> t accessModeBag :: ActorId -> State -> ItemDialogMode -> ItemBag accessModeBag leader s (MStore cstore) = let b = getActorBody leader s in getBodyStoreBag b cstore s accessModeBag leader s MOrgans = let b = getActorBody leader s in getBodyStoreBag b COrgan s accessModeBag leader s MOwned = let fid = bfid $ getActorBody leader s in combinedItems fid s accessModeBag _ _ MStats = EM.empty accessModeBag _ s MLore{} = EM.map (const (1, [])) $ sitemD s -- | 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 -> [CStore] -- ^ initial legal modes -> [CStore] -- ^ legal modes after Calm taken into account -> m (Either Text ( (ItemId, ItemFull) , (ItemDialogMode, Either K.KM SlotChar) )) getGroupItem psuit prompt promptGeneric cLegalRaw cLegalAfterCalm = do soc <- getFull psuit (\_ _ _ cCur -> prompt <+> ppItemDialogModeFrom cCur) (\_ _ _ cCur -> promptGeneric <+> ppItemDialogModeFrom cCur) cLegalRaw cLegalAfterCalm True False case soc of Left err -> return $ Left err Right ([(iid, (itemFull, _))], cekm) -> return $ Right ((iid, itemFull), cekm) Right _ -> error $ "" `showFailure` soc -- | Display all items from a store and let the human player choose any -- or switch to any other store. -- Used, e.g., for viewing inventory and item descriptions. getStoreItem :: MonadClientUI m => (Actor -> ActorUI -> IA.AspectRecord -> ItemDialogMode -> Text) -- ^ how to describe suitable items -> ItemDialogMode -- ^ initial mode -> m ( Either Text (ItemId, ItemBag, SingleItemSlots) , (ItemDialogMode, Either K.KM SlotChar) ) getStoreItem prompt cInitial = do let itemCs = map MStore [CInv, CGround, CEqp, CSha] allCs = case cInitial of MLore{} -> map MLore [minBound..maxBound] _ -> itemCs ++ [MOwned, MOrgans, MStats] (pre, rest) = break (== cInitial) allCs post = dropWhile (== cInitial) rest remCs = post ++ pre soc <- getItem (return SuitsEverything) prompt prompt cInitial remCs True False (cInitial : remCs) case soc of (Left err, cekm) -> return (Left err, cekm) (Right ([iid], itemBag, lSlots), cekm) -> return (Right (iid, itemBag, lSlots), cekm) (Right{}, _) -> error $ "" `showFailure` 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 -> ActorUI -> IA.AspectRecord -> ItemDialogMode -> Text) -- ^ specific prompt for only suitable items -> (Actor -> ActorUI -> IA.AspectRecord -> ItemDialogMode -> Text) -- ^ generic prompt -> [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 -> m (Either Text ( [(ItemId, ItemFullKit)] , (ItemDialogMode, Either K.KM SlotChar) )) getFull psuit prompt promptGeneric cLegalRaw cLegalAfterCalm askWhenLone permitMulitple = do side <- getsClient sside leader <- getLeaderUI let aidNotEmpty store aid = do body <- getsState $ getActorBody aid bag <- getsState $ getBodyStoreBag body 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 -> \_ _ -> True SuitsSomething f -> f -- Move the first store that is non-empty for suitable items for this actor -- to the front, if any. b <- getsState $ getActorBody leader getCStoreBag <- getsState $ \s cstore -> getBodyStoreBag b cstore s let hasThisActor = not . EM.null . getCStoreBag case filter hasThisActor 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] return $ Left $ "no items" <+> ppLegal else return $ Left $ showReqFailure ItemNotCalm haveThis@(headThisActor : _) -> do itemToF <- getsState $ flip itemToFull let suitsThisActor store = let bag = getCStoreBag store in any (\(iid, kit) -> psuitFun (itemToF iid) kit) $ EM.assocs bag firstStore = fromMaybe headThisActor $ 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) let (modeFirst, modeRest) = breakStores firstStore res <- getItem psuit prompt promptGeneric modeFirst modeRest askWhenLone permitMulitple (map MStore cLegal) case res of (Left t, _) -> return $ Left t (Right (iids, itemBag, _lSlots), cekm) -> do let f iid = (iid, (itemToF iid, itemBag EM.! iid)) return $ Right (map f iids, cekm) -- | 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 -> ActorUI -> IA.AspectRecord -> ItemDialogMode -> Text) -- ^ specific prompt for only suitable items -> (Actor -> ActorUI -> IA.AspectRecord -> ItemDialogMode -> Text) -- ^ generic prompt -> 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 -> m ( Either Text ([ItemId], ItemBag, SingleItemSlots) , (ItemDialogMode, Either K.KM SlotChar) ) getItem psuit prompt promptGeneric cCur cRest askWhenLone permitMulitple cLegal = 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 ItemSlots itemSlots <- getsSession sslots let lSlots = itemSlots EM.! loreFromMode cCur slotChar = fromMaybe (error $ "" `showFailure` (iid, lSlots)) $ lookup iid $ map swap $ EM.assocs lSlots return ( Right ([iid], EM.singleton iid k, EM.singleton slotChar iid) , (cCur, Right slotChar) ) _ -> transition psuit prompt promptGeneric permitMulitple cLegal 0 cCur cRest ISuitable data DefItemKey m = DefItemKey { defLabel :: Either Text K.KM , defCond :: Bool , defAction :: Either K.KM SlotChar -> m ( Either Text ([ItemId], ItemBag, SingleItemSlots) , (ItemDialogMode, Either K.KM SlotChar) ) } data Suitability = SuitsEverything | SuitsSomething (ItemFull -> ItemQuant -> Bool) transition :: forall m. MonadClientUI m => m Suitability -> (Actor -> ActorUI -> IA.AspectRecord -> ItemDialogMode -> Text) -> (Actor -> ActorUI -> IA.AspectRecord -> ItemDialogMode -> Text) -> Bool -> [ItemDialogMode] -> Int -> ItemDialogMode -> [ItemDialogMode] -> ItemDialogState -> m ( Either Text ([ItemId], ItemBag, SingleItemSlots) , (ItemDialogMode, Either K.KM SlotChar) ) transition psuit prompt promptGeneric permitMulitple cLegal numPrefix cCur cRest itemDialogState = do let recCall = transition psuit prompt promptGeneric permitMulitple cLegal ItemSlots itemSlots <- getsSession sslots leader <- getLeaderUI body <- getsState $ getActorBody leader bodyUI <- getsSession $ getActorUI leader ar <- getsState $ getActorAspect leader fact <- getsState $ (EM.! bfid body) . sfactionD hs <- partyAfterLeader leader bagAll <- getsState $ \s -> accessModeBag leader s cCur itemToF <- getsState $ flip itemToFull organPartySet <- getsState $ partyItemSet SOrgan (bfid body) (Just body) revCmd <- revCmdMap mpsuit <- psuit -- when throwing, this sets eps and checks xhair validity psuitFun <- case mpsuit of SuitsEverything -> return $ \_ _ -> True SuitsSomething f -> return f -- When throwing, this function takes missile range into accout. let getResult :: Either K.KM SlotChar -> [ItemId] -> ( Either Text ([ItemId], ItemBag, SingleItemSlots) , (ItemDialogMode, Either K.KM SlotChar) ) getResult ekm iids = (Right (iids, bagAll, bagItemSlotsAll), (cCur, ekm)) filterP iid = psuitFun (itemToF iid) bagAllSuit = EM.filterWithKey filterP bagAll lSlots = case cCur of MOrgans -> mergeItemSlots itemToF organPartySet [ itemSlots EM.! SOrgan , itemSlots EM.! STrunk , itemSlots EM.! STmp ] MStats -> EM.empty _ -> itemSlots EM.! loreFromMode cCur 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 bagSuit = EM.fromList $ map (\iid -> (iid, bagAllSuit EM.! iid)) (EM.elems suitableItemSlotsOpen) (autoDun, _) = autoDungeonLevel fact multipleSlots = if itemDialogState == IAll then bagItemSlotsAll else suitableItemSlotsAll maySwitchLeader MOwned = False maySwitchLeader MLore{} = False maySwitchLeader _ = True keyDefs :: [(K.KM, DefItemKey m)] keyDefs = filter (defCond . snd) $ [ let km = K.mkChar '/' in (km, changeContainerDef $ Right km) , (K.mkKP '/', changeContainerDef $ Left "") , let km = K.mkChar '?' in (km, DefItemKey { defLabel = Right km , defCond = bag /= bagSuit , defAction = \_ -> recCall numPrefix cCur cRest $ case itemDialogState of ISuitable -> IAll IAll -> ISuitable }) , let km = K.mkChar '!' in (km, useMultipleDef $ Right km) , (K.mkKP '*', useMultipleDef $ Left "") , let km = revCmd (K.KM K.NoModifier K.Tab) MemberCycle in (km, DefItemKey { defLabel = Right km , defCond = maySwitchLeader cCur && any (\(_, b, _) -> blid b == blid body) hs , defAction = \_ -> do err <- memberCycle False let !_A = assert (isNothing err `blame` err) () (cCurUpd, cRestUpd) <- legalWithUpdatedLeader cCur cRest recCall numPrefix cCurUpd cRestUpd itemDialogState }) , let km = revCmd (K.KM K.NoModifier K.BackTab) MemberBack in (km, DefItemKey { defLabel = Right km , defCond = maySwitchLeader cCur && not (autoDun || null hs) , defAction = \_ -> do err <- memberBack False let !_A = assert (isNothing err `blame` err) () (cCurUpd, cRestUpd) <- legalWithUpdatedLeader cCur cRest recCall numPrefix cCurUpd cRestUpd itemDialogState }) , (K.KM K.NoModifier K.LeftButtonRelease, DefItemKey { defLabel = Left "" , defCond = maySwitchLeader cCur && not (null hs) , defAction = \_unused -> do merror <- pickLeaderWithPointer case merror of Nothing -> do (cCurUpd, cRestUpd) <- legalWithUpdatedLeader cCur cRest recCall numPrefix cCurUpd cRestUpd itemDialogState Just{} -> -- don't inspect the error, it's expected defAction (changeContainerDef $ Left "") _unused }) , let km = revCmd (K.KM K.NoModifier $ K.Char '^') SortSlots in (km, DefItemKey { defLabel = Right km , defCond = cCur /= MOrgans -- auto-sorted each time && cCur /= MStats -- artificial slots , defAction = \_ -> do sortSlots (bfid body) (Just body) recCall numPrefix cCur cRest itemDialogState }) , (K.escKM, DefItemKey { defLabel = Right K.escKM , defCond = True , defAction = \ekm -> return (Left "never mind", (cCur, ekm)) }) ] ++ numberPrefixes changeContainerDef defLabel = DefItemKey { defLabel , defCond = True -- even if single screen, just reset it , defAction = \_ -> do let calmE = calmEnough body ar 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 -> error $ "" `showFailure` cRest c1 : rest -> (c1, rest) [] -> error $ "" `showFailure` cRest recCall numPrefix cCurAfterCalm cRestAfterCalm itemDialogState } useMultipleDef defLabel = DefItemKey { defLabel , defCond = permitMulitple && not (EM.null multipleSlots) , defAction = \ekm -> let eslots = EM.elems multipleSlots in return $ getResult ekm eslots } prefixCmdDef d = (K.mkChar $ Char.intToDigit d, DefItemKey { defLabel = Left "" , defCond = True , defAction = \_ -> recCall (10 * numPrefix + d) cCur cRest itemDialogState }) numberPrefixes = map prefixCmdDef [0..9] lettersDef :: DefItemKey m lettersDef = DefItemKey { defLabel = Left "" , defCond = True , defAction = \ekm -> let slot = case ekm of Left K.KM{key} -> case key of K.Char l -> SlotChar numPrefix l _ -> error $ "unexpected key:" `showFailure` K.showKey key Right sl -> sl in case EM.lookup slot bagItemSlotsAll of Nothing -> error $ "unexpected slot" `showFailure` (slot, bagItemSlots) Just iid -> return $! getResult (Right slot) [iid] } (bagFiltered, promptChosen) = case itemDialogState of ISuitable -> (bagSuit, prompt body bodyUI ar cCur <> ":") IAll -> (bag, promptGeneric body bodyUI ar cCur <> ":") case cCur of MStats -> do io <- statsOverlay leader let slotLabels = map fst $ snd io slotKeys = mapMaybe (keyOfEKM numPrefix) slotLabels statsDef :: DefItemKey m statsDef = DefItemKey { defLabel = Left "" , defCond = True , defAction = \ekm -> let slot = case ekm of Left K.KM{key} -> case key of K.Char l -> SlotChar numPrefix l _ -> error $ "unexpected key:" `showFailure` K.showKey key Right sl -> sl in return (Left "stats", (MStats, Right slot)) } runDefItemKey keyDefs statsDef io slotKeys promptChosen cCur _ -> do io <- itemOverlay lSlots (blid body) bagFiltered let slotKeys = mapMaybe (keyOfEKM numPrefix . Right) $ EM.keys bagItemSlots runDefItemKey keyDefs lettersDef io slotKeys promptChosen cCur keyOfEKM :: Int -> Either [K.KM] SlotChar -> Maybe K.KM keyOfEKM _ (Left kms) = error $ "" `showFailure` kms keyOfEKM numPrefix (Right SlotChar{..}) | slotPrefix == numPrefix = Just $ K.mkChar slotChar keyOfEKM _ _ = Nothing 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 ar <- getsState $ getActorAspect leader let calmE = calmEnough b ar 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) [] -> error $ "" `showFailure` (cCur, cRest) return legalAfterCalm -- We don't create keys from slots in @okx@, so they have to be -- exolicitly given in @slotKeys@. runDefItemKey :: MonadClientUI m => [(K.KM, DefItemKey m)] -> DefItemKey m -> OKX -> [K.KM] -> Text -> ItemDialogMode -> m ( Either Text ([ItemId], ItemBag, SingleItemSlots) , (ItemDialogMode, Either K.KM SlotChar) ) runDefItemKey keyDefs lettersDef okx slotKeys prompt cCur = do let itemKeys = slotKeys ++ map fst keyDefs wrapB s = "[" <> s <> "]" (keyLabelsRaw, keys) = partitionEithers $ map (defLabel . snd) keyDefs keyLabels = filter (not . T.null) keyLabelsRaw choice = T.intercalate " " $ map wrapB $ nub keyLabels promptAdd0 $ prompt <+> choice lidV <- viewedLevelUI Level{lysize} <- getLevel lidV ekm <- do okxs <- overlayToSlideshow (lysize + 1) keys okx displayChoiceScreen (show cCur) ColorFull False okxs itemKeys case ekm of Left km -> case km `lookup` keyDefs of Just keyDef -> defAction keyDef ekm Nothing -> defAction lettersDef ekm -- pressed; with current prefix Right _slot -> defAction lettersDef ekm -- selected; with the given prefix LambdaHack-0.8.3.0/Game/LambdaHack/Client/UI/SessionUI.hs0000644000000000000000000001757613315545734020637 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | The client UI session state. module Game.LambdaHack.Client.UI.SessionUI ( SessionUI(..), AimMode(..), RunParams(..), LastRecord(..), HintMode(..) , emptySessionUI, toggleMarkVision, toggleMarkSmell, getActorUI ) where import Prelude () import Game.LambdaHack.Common.Prelude import Data.Binary import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES import qualified Data.Map.Strict as M import Data.Time.Clock.POSIX import Game.LambdaHack.Client.UI.ActorUI import Game.LambdaHack.Client.UI.Frontend import Game.LambdaHack.Client.UI.ItemSlot import qualified Game.LambdaHack.Client.UI.Key as K import Game.LambdaHack.Client.UI.KeyBindings import Game.LambdaHack.Client.UI.Msg import Game.LambdaHack.Client.UI.UIOptions import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.Item import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.Time import Game.LambdaHack.Common.Vector -- | The information that is used across a client playing session, -- including many consecutive games in a single session. -- Some of it is saved, some is reset when a new playing session starts. -- An important component is the frontend session. data SessionUI = SessionUI { sxhair :: Target -- ^ the common xhair , sactorUI :: ActorDictUI -- ^ assigned actor UI presentations , sslots :: ItemSlots -- ^ map from slots to items , slastItemMove :: Maybe (CStore, CStore) -- ^ last item move stores , schanF :: ChanFrontend -- ^ connection with the frontend , sbinding :: Binding -- ^ binding of keys to commands , sUIOptions :: UIOptions -- ^ UI options as set by the player , saimMode :: Maybe AimMode -- ^ aiming mode , sxhairMoused :: Bool -- ^ last mouse aiming not vacuus , sitemSel :: Maybe (ItemId, CStore, Bool) -- ^ selected item, if any, it's store and -- whether to override suitability check , sselected :: ES.EnumSet ActorId -- ^ the set of currently selected actors , srunning :: Maybe RunParams -- ^ parameters of the current run, if any , shistory :: History -- ^ history of messages , spointer :: Point -- ^ mouse pointer position , 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 , smarkVision :: Bool -- ^ mark leader and party FOV , smarkSmell :: Bool -- ^ mark smell, if the leader can smell , smenuIxMap :: M.Map String Int -- ^ indices of last used menu items , sdisplayNeeded :: Bool -- ^ current level needs displaying , shintMode :: HintMode -- ^ how to show keys hints when no messages , sreportNull :: Bool -- ^ whether no report created last UI turn , sstart :: POSIXTime -- ^ this session start time , sgstart :: POSIXTime -- ^ this game start time , sallTime :: Time -- ^ clips from start of session -- to current game start , snframes :: Int -- ^ this game current frame count , sallNframes :: Int -- ^ frame count from start of session -- to current game start } -- | Current aiming mode of a client. newtype AimMode = AimMode { aimLevelId :: 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) -- | State of last recorded and currently being recorded key sequences. data LastRecord = LastRecord { currentKeys :: [K.KM] -- ^ accumulated keys of the current command , previousKeys :: [K.KM] -- ^ keys of the rest of the recorded command batch , freeSpace :: Int -- ^ space left for commands to record in this batch } data HintMode = HintAbsent | HintShown | HintWiped deriving (Eq, Enum, Bounded) emptySessionUI :: UIOptions -> SessionUI emptySessionUI sUIOptions = SessionUI { sxhair = TVector $ Vector 0 0 , sactorUI = EM.empty , sslots = ItemSlots $ EM.fromAscList $ zip [minBound..maxBound] (repeat EM.empty) , slastItemMove = Nothing , schanF = ChanFrontend $ const $ error $ "emptySessionUI: ChanFrontend" `showFailure` () , sbinding = Binding M.empty [] M.empty , sUIOptions , saimMode = Nothing , sxhairMoused = True , sitemSel = Nothing , sselected = ES.empty , srunning = Nothing , shistory = emptyHistory 0 , spointer = originPoint , slastRecord = LastRecord [] [] 0 , slastPlay = [] , slastLost = ES.empty , swaitTimes = 0 , smarkVision = False , smarkSmell = True , smenuIxMap = M.singleton "main" 2 , sdisplayNeeded = False , sreportNull = True , shintMode = HintAbsent , sstart = 0 , sgstart = 0 , sallTime = timeZero , snframes = 0 , sallNframes = 0 } toggleMarkVision :: SessionUI -> SessionUI toggleMarkVision s@SessionUI{smarkVision} = s {smarkVision = not smarkVision} toggleMarkSmell :: SessionUI -> SessionUI toggleMarkSmell s@SessionUI{smarkSmell} = s {smarkSmell = not smarkSmell} getActorUI :: ActorId -> SessionUI -> ActorUI getActorUI aid sess = EM.findWithDefault (error $ "" `showFailure` (aid, sactorUI sess)) aid $ sactorUI sess instance Binary SessionUI where put SessionUI{..} = do put sxhair put sactorUI put sslots put sUIOptions put saimMode put sitemSel put sselected put srunning put shistory put smarkVision put smarkSmell put sdisplayNeeded get = do sxhair <- get sactorUI <- get sslots <- get sUIOptions <- get -- is overwritten ASAP, but useful for, e.g., crash debug saimMode <- get sitemSel <- get sselected <- get srunning <- get shistory <- get smarkVision <- get smarkSmell <- get sdisplayNeeded <- get let slastItemMove = Nothing schanF = ChanFrontend $ const $ error $ "Binary: ChanFrontend" `showFailure` () sbinding = Binding M.empty [] M.empty sxhairMoused = True spointer = originPoint slastRecord = LastRecord [] [] 0 slastPlay = [] slastLost = ES.empty swaitTimes = 0 smenuIxMap = M.singleton "main" 7 sreportNull = True shintMode = HintAbsent sstart = 0 sgstart = 0 sallTime = timeZero snframes = 0 sallNframes = 0 return $! SessionUI{..} instance Binary RunParams where put RunParams{..} = do put runLeader put runMembers put runInitial put runStopMsg put runWaiting get = do runLeader <- get runMembers <- get runInitial <- get runStopMsg <- get runWaiting <- get return $! RunParams{..} LambdaHack-0.8.3.0/Game/LambdaHack/Client/UI/MonadClientUI.hs0000644000000000000000000003713713315545734021404 0ustar0000000000000000-- | Client monad for interacting with a human through UI. module Game.LambdaHack.Client.UI.MonadClientUI ( -- * Client UI monad MonadClientUI( getsSession , modifySession , liftIO -- exposed only to be implemented, not used, ) -- * Assorted primitives , clientPrintUI, mapStartY, getSession, putSession, displayFrames , connFrontendFrontKey, setFrontAutoYes, frontendShutdown, printScreen , chanFrontend, anyKeyPressed, discardPressedKey, addPressedEsc, revCmdMap , getReportUI, getLeaderUI, getArenaUI, viewedLevelUI , leaderTgtToPos, xhairToPos, clearXhair, clearAimMode , scoreToSlideshow, defaultHistory , tellAllClipPS, tellGameClipPS, elapsedSessionTimeGT , resetSessionStart, resetGameStart , partActorLeader, partActorLeaderFun, partPronounLeader, partAidLeader , tryRestore, leaderSkillsClientUI #ifdef EXPOSE_INTERNAL -- * Internal operations , connFrontend, displayFrame, addPressedKey #endif ) where import Prelude () import Game.LambdaHack.Common.Prelude import qualified Data.EnumMap.Strict as EM import qualified Data.Map.Strict as M import qualified Data.Text as T import qualified Data.Text.IO as T import Data.Time.Clock import Data.Time.Clock.POSIX import Data.Time.LocalTime import qualified NLP.Miniutter.English as MU import System.FilePath import System.IO (hFlush, stdout) import Game.LambdaHack.Client.ClientOptions import Game.LambdaHack.Client.CommonM import Game.LambdaHack.Client.MonadClient hiding (liftIO) import Game.LambdaHack.Client.State import Game.LambdaHack.Client.UI.ActorUI import Game.LambdaHack.Client.UI.Frame import Game.LambdaHack.Client.UI.Frontend import qualified Game.LambdaHack.Client.UI.Frontend as Frontend import qualified Game.LambdaHack.Client.UI.HumanCmd as HumanCmd import qualified Game.LambdaHack.Client.UI.Key as K import Game.LambdaHack.Client.UI.KeyBindings import Game.LambdaHack.Client.UI.Msg import Game.LambdaHack.Client.UI.Overlay import Game.LambdaHack.Client.UI.SessionUI import Game.LambdaHack.Client.UI.Slideshow import 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.File import qualified Game.LambdaHack.Common.HighScore as HighScore import Game.LambdaHack.Common.Kind import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.MonadStateRead import Game.LambdaHack.Common.Point import qualified Game.LambdaHack.Common.Save as Save import Game.LambdaHack.Common.State import Game.LambdaHack.Common.Time import Game.LambdaHack.Content.ModeKind import Game.LambdaHack.Content.RuleKind -- Assumes no interleaving with other clients, because each UI client -- in a different terminal/window/machine. clientPrintUI :: MonadClientUI m => Text -> m () clientPrintUI t = liftIO $ do T.hPutStrLn stdout t hFlush stdout -- | The row where the dungeon map starts. mapStartY :: Y mapStartY = 1 -- | The monad that gives the client access to UI operations. class MonadClient m => MonadClientUI m where getsSession :: (SessionUI -> a) -> m a modifySession :: (SessionUI -> SessionUI) -> m () liftIO :: IO a -> m a getSession :: MonadClientUI m => m SessionUI getSession = getsSession id putSession :: MonadClientUI m => SessionUI -> m () putSession s = modifySession (const s) -- | Write a UI request to the frontend and read a corresponding reply. connFrontend :: MonadClientUI m => FrontReq a -> m a connFrontend req = do ChanFrontend f <- getsSession schanF liftIO $ f req displayFrame :: MonadClientUI m => Maybe FrameForall -> m () displayFrame mf = do frame <- case mf of Nothing -> return $! FrontDelay 1 Just fr -> do modifySession $ \cli -> cli {snframes = snframes cli + 1} return $! FrontFrame fr connFrontend frame -- | Push frames or delays to the frame queue. The frames depict -- the @lid@ level. displayFrames :: MonadClientUI m => LevelId -> Frames -> m () displayFrames lid frs = do mapM_ displayFrame frs -- Can be different than @blid b@, e.g., when our actor is attacked -- on a remote level. lidV <- viewedLevelUI when (lidV == lid) $ modifySession $ \sess -> sess {sdisplayNeeded = False} -- | Write 'FrontKey' UI request to the frontend, read the reply, -- set pointer, return key. connFrontendFrontKey :: MonadClientUI m => [K.KM] -> FrameForall -> m K.KM connFrontendFrontKey frontKeyKeys frontKeyFrame = do kmp <- connFrontend FrontKey{..} modifySession $ \sess -> sess {spointer = K.kmpPointer kmp} return $! K.kmpKeyMod kmp setFrontAutoYes :: MonadClientUI m => Bool -> m () setFrontAutoYes b = connFrontend $ FrontAutoYes b frontendShutdown :: MonadClientUI m => m () frontendShutdown = connFrontend FrontShutdown printScreen :: MonadClientUI m => m () printScreen = connFrontend FrontPrintScreen -- | Initialize the frontend chosen by the player via client options. chanFrontend :: MonadClientUI m => ClientOptions -> m ChanFrontend chanFrontend = liftIO . Frontend.chanFrontendIO anyKeyPressed :: MonadClientUI m => m Bool anyKeyPressed = connFrontend FrontPressed discardPressedKey :: MonadClientUI m => m () discardPressedKey = connFrontend FrontDiscard addPressedKey :: MonadClientUI m => K.KMP -> m () addPressedKey = connFrontend . FrontAdd addPressedEsc :: MonadClientUI m => m () addPressedEsc = addPressedKey K.KMP { K.kmpKeyMod = K.escKM , K.kmpPointer = originPoint } revCmdMap :: MonadClientUI m => m (K.KM -> HumanCmd.HumanCmd -> K.KM) revCmdMap = do Binding{brevMap} <- getsSession sbinding let revCmd dflt cmd = case M.lookup cmd brevMap of Nothing -> dflt Just (k : _) -> k Just [] -> error $ "" `showFailure` brevMap return revCmd getReportUI :: MonadClientUI m => m Report getReportUI = do report <- getsSession $ newReport . shistory side <- getsClient sside fact <- getsState $ (EM.! side) . sfactionD let underAI = isAIFact fact promptAI = toPrompt $ stringToAL "[press ESC for main menu]" return $! if underAI then consReport promptAI report else report getLeaderUI :: MonadClientUI m => m ActorId getLeaderUI = do cli <- getClient case sleader cli of Nothing -> error $ "leader expected but not found" `showFailure` cli Just leader -> return leader getArenaUI :: MonadClientUI m => m LevelId getArenaUI = do let fallback = do side <- getsClient sside fact <- getsState $ (EM.! side) . sfactionD case gquit fact of Just Status{stDepth} -> return $! toEnum stDepth Nothing -> getEntryArena fact mleader <- getsClient sleader case mleader of Just leader -> do -- The leader may just be teleporting (e.g., due to displace -- over terrain not in FOV) so not existent momentarily. mem <- getsState $ EM.member leader . sactorD if mem then getsState $ blid . getActorBody leader else fallback Nothing -> fallback viewedLevelUI :: MonadClientUI m => m LevelId viewedLevelUI = do arena <- getArenaUI saimMode <- getsSession saimMode return $! maybe arena aimLevelId saimMode leaderTgtToPos :: MonadClientUI m => m (Maybe Point) leaderTgtToPos = do lidV <- viewedLevelUI mleader <- getsClient sleader case mleader of Nothing -> return Nothing Just aid -> do mtgt <- getsClient $ getTarget aid case mtgt of Nothing -> return Nothing Just tgt -> getsState $ aidTgtToPos aid lidV tgt xhairToPos :: MonadClientUI m => m (Maybe Point) xhairToPos = do lidV <- viewedLevelUI mleader <- getsClient sleader sxhair <- getsSession sxhair case mleader of Nothing -> return Nothing -- e.g., when game start and no leader yet Just aid -> getsState $ aidTgtToPos aid lidV sxhair -- e.g., xhair on another level -- Reset xhair and move it to actor's position. clearXhair :: MonadClientUI m => m () clearXhair = do leader <- getLeaderUI lpos <- getsState $ bpos . getActorBody leader lidV <- viewedLevelUI -- don't assume aiming mode is or will be off modifySession $ \sess -> sess {sxhair = TPoint TAny lidV lpos} -- If aim mode is exited, usually the player had the opportunity to deal -- with xhair on a foe spotted on another level, so now move xhair -- back to the leader level. clearAimMode :: MonadClientUI m => m () clearAimMode = do leader <- getLeaderUI lpos <- getsState $ bpos . getActorBody leader xhairPos <- xhairToPos -- computed while still in aiming mode modifySession $ \sess -> sess {saimMode = Nothing} lidV <- viewedLevelUI -- not in aiming mode at this point sxhairOld <- getsSession sxhair let cpos = fromMaybe lpos xhairPos sxhair = case sxhairOld of TEnemy{} -> sxhairOld TVector{} -> sxhairOld _ -> TPoint TAny lidV cpos modifySession $ \sess -> sess {sxhair} scoreToSlideshow :: MonadClientUI m => Int -> Status -> m Slideshow scoreToSlideshow total status = do lidV <- viewedLevelUI Level{lxsize, lysize} <- getLevel lidV fid <- getsClient sside scoreDict <- getsState shigh gameModeId <- getsState sgameModeId gameMode <- getGameMode time <- getsState stime dungeonTotal <- getsState sgold date <- liftIO getPOSIXTime tz <- liftIO $ getTimeZone $ posixSecondsToUTCTime date curChalSer <- getsClient scurChal factionD <- getsState sfactionD let fact = factionD EM.! fid table = HighScore.getTable gameModeId scoreDict gameModeName = mname gameMode chal | fhasUI $ gplayer fact = curChalSer | otherwise = curChalSer {cdiff = difficultyInverse (cdiff curChalSer)} theirVic (fi, fa) | isFoe fid fact fi && not (isHorrorFact fa) = Just $ gvictims fa | otherwise = Nothing theirVictims = EM.unionsWith (+) $ mapMaybe theirVic $ EM.assocs factionD ourVic (fi, fa) | isFriend fid fact fi = Just $ gvictims fa | otherwise = Nothing ourVictims = EM.unionsWith (+) $ mapMaybe ourVic $ EM.assocs factionD (worthMentioning, (ntable, pos)) = HighScore.register table total dungeonTotal time status date chal (T.unwords $ tail $ T.words $ gname fact) ourVictims theirVictims (fhiCondPoly $ gplayer fact) (msg, tts) = HighScore.highSlideshow ntable pos gameModeName tz al = textToAL msg splitScreen ts = splitOKX lxsize (lysize + 3) al [K.spaceKM, K.escKM] (ts, []) sli = toSlideshow $ concat $ map (splitScreen . map textToAL) tts return $! if worthMentioning then sli else emptySlideshow defaultHistory :: MonadClientUI m => Int -> m History defaultHistory uHistoryMax = liftIO $ do utcTime <- getCurrentTime timezone <- getTimeZone utcTime let curDate = take 19 $ show $ utcToLocalTime timezone utcTime emptyHist = emptyHistory uHistoryMax msg = toMsg $ stringToAL $ "History log started on " ++ curDate ++ "." return $! fst $ addToReport emptyHist msg 0 tellAllClipPS :: MonadClientUI m => m () tellAllClipPS = do bench <- getsClient $ sbenchmark . soptions when bench $ do sstartPOSIX <- getsSession sstart curPOSIX <- liftIO getPOSIXTime allTime <- getsSession sallTime gtime <- getsState stime allNframes <- getsSession sallNframes gnframes <- getsSession snframes let time = absoluteTimeAdd allTime gtime nframes = allNframes + gnframes diff = fromRational $ toRational $ curPOSIX - sstartPOSIX cps = fromIntegral (timeFit time timeClip) / diff :: Double fps = fromIntegral nframes / diff :: Double clientPrintUI $ "Session time:" <+> tshow diff <> "s; frames:" <+> tshow nframes <> "." <+> "Average clips per second:" <+> tshow cps <> "." <+> "Average FPS:" <+> tshow fps <> "." tellGameClipPS :: MonadClientUI m => m () tellGameClipPS = do bench <- getsClient $ sbenchmark . soptions when bench $ do sgstartPOSIX <- getsSession sgstart curPOSIX <- liftIO getPOSIXTime -- If loaded game, don't report anything. unless (sgstartPOSIX == 0) $ do time <- getsState stime nframes <- getsSession snframes let diff = fromRational $ toRational $ curPOSIX - sgstartPOSIX cps = fromIntegral (timeFit time timeClip) / diff :: Double fps = fromIntegral nframes / diff :: Double -- This means: "Game portion after last reload time:...". clientPrintUI $ "Game time:" <+> tshow diff <> "s; frames:" <+> tshow nframes <> "." <+> "Average clips per second:" <+> tshow cps <> "." <+> "Average FPS:" <+> tshow fps <> "." elapsedSessionTimeGT :: MonadClientUI m => Int -> m Bool elapsedSessionTimeGT stopAfter = do current <- liftIO getPOSIXTime sstartPOSIX <- getsSession sstart return $! fromIntegral stopAfter + sstartPOSIX <= current resetSessionStart :: MonadClientUI m => m () resetSessionStart = do sstart <- liftIO getPOSIXTime modifySession $ \sess -> sess {sstart} resetGameStart resetGameStart :: MonadClientUI m => m () resetGameStart = do sgstart <- liftIO getPOSIXTime time <- getsState stime nframes <- getsSession snframes modifySession $ \cli -> cli { sgstart , sallTime = absoluteTimeAdd (sallTime cli) time , snframes = 0 , sallNframes = sallNframes cli + nframes } -- | 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 :: MonadClientUI m => ActorId -> ActorUI -> m MU.Part partActorLeader aid b = do mleader <- getsClient sleader return $! case mleader of Just leader | aid == leader -> "you" _ -> partActor b partActorLeaderFun :: MonadClientUI m => m (ActorId -> MU.Part) partActorLeaderFun = do mleader <- getsClient sleader sess <- getSession return $! \aid -> if mleader == Just aid then "you" else partActor $ getActorUI aid sess -- | 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 -> ActorUI -> 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 :: MonadClientUI m => ActorId -> m MU.Part partAidLeader aid = do b <- getsSession $ getActorUI aid partActorLeader aid b -- | Try to read saved client game state from the file system. tryRestore :: MonadClientUI m => m (Maybe (StateClient, Maybe SessionUI)) tryRestore = do cops <- getsState scops bench <- getsClient $ sbenchmark . soptions if bench then return Nothing else do side <- getsClient sside prefix <- getsClient $ ssavePrefixCli . soptions let fileName = prefix <> Save.saveNameCli cops side res <- liftIO $ Save.restoreGame cops fileName let stdRuleset = getStdRuleset cops cfgUIName = rcfgUIName stdRuleset content = rcfgUIDefault stdRuleset dataDir <- liftIO appDataDir liftIO $ tryWriteFile (dataDir cfgUIName) content return res leaderSkillsClientUI :: MonadClientUI m => m Ability.Skills leaderSkillsClientUI = do leader <- getLeaderUI maxActorSkillsClient leader LambdaHack-0.8.3.0/Game/LambdaHack/Client/UI/DisplayAtomicM.hs0000644000000000000000000016163713315545734021633 0ustar0000000000000000-- | Display atomic commands received by the client. module Game.LambdaHack.Client.UI.DisplayAtomicM ( displayRespUpdAtomicUI, displayRespSfxAtomicUI #ifdef EXPOSE_INTERNAL -- * Internal operations , updateItemSlot, markDisplayNeeded, lookAtMove , actorVerbMU, aidVerbMU, aidVerbDuplicateMU, itemVerbMU, itemAidVerbMU , createActorUI, destroyActorUI, spotItem, moveActor, displaceActorUI , moveItemUI, quitFactionUI, discover, ppSfxMsg, strike #endif ) where import Prelude () import Game.LambdaHack.Common.Prelude import qualified Data.Char as Char import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES import Data.Key (mapWithKeyM_) import qualified Data.Map.Strict as M import qualified Data.Text as T import Data.Tuple import GHC.Exts (inline) import qualified NLP.Miniutter.English as MU import Game.LambdaHack.Atomic import Game.LambdaHack.Client.MonadClient import Game.LambdaHack.Client.State import Game.LambdaHack.Client.UI.ActorUI import Game.LambdaHack.Client.UI.Animation import Game.LambdaHack.Client.UI.EffectDescription import Game.LambdaHack.Client.UI.FrameM import Game.LambdaHack.Client.UI.HandleHelperM import qualified Game.LambdaHack.Client.UI.HumanCmd as HumanCmd import Game.LambdaHack.Client.UI.ItemDescription import Game.LambdaHack.Client.UI.ItemSlot import qualified Game.LambdaHack.Client.UI.Key as K import Game.LambdaHack.Client.UI.MonadClientUI import Game.LambdaHack.Client.UI.Msg import Game.LambdaHack.Client.UI.MsgM import Game.LambdaHack.Client.UI.Overlay import Game.LambdaHack.Client.UI.SessionUI import Game.LambdaHack.Client.UI.Slideshow import Game.LambdaHack.Client.UI.SlideshowM import Game.LambdaHack.Client.UI.UIOptions import Game.LambdaHack.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.Flavour import Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.ItemAspect as IA import Game.LambdaHack.Common.Kind import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.MonadStateRead import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.ReqFailure import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile import Game.LambdaHack.Common.Time import Game.LambdaHack.Content.CaveKind (cdesc) 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 -- | Visualize atomic updates sent to the client. This is done -- in the global state after the command is executed and after -- the client state is modified by the command. displayRespUpdAtomicUI :: MonadClientUI m => Bool -> UpdAtomic -> m () {-# INLINE displayRespUpdAtomicUI #-} displayRespUpdAtomicUI verbose cmd = case cmd of -- Create/destroy actors and items. UpdCreateActor aid body _ -> createActorUI True aid body UpdDestroyActor aid body _ -> destroyActorUI True aid body UpdCreateItem iid _item kit c -> do updateItemSlot c iid case c of CActor aid store -> case store of COrgan -> do itemKind <- getsState $ getIidKind iid if IK.isTmpCondition itemKind then do bag <- getsState $ getContainerBag c let more = case EM.lookup iid bag of Nothing -> False Just kit2 -> fst kit2 /= fst kit verb = MU.Text $ "become" <+> case fst kit of 1 -> if more then "more" else "" k -> (if more then "additionally" else "") <+> 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 else do ownerFun <- partActorLeaderFun let wown = ppContainerWownW ownerFun True c itemVerbMU iid kit (MU.Text $ makePhrase $ "grow" : wown) c _ -> do ownerFun <- partActorLeaderFun let wown = ppContainerWownW ownerFun True c itemVerbMU iid kit (MU.Text $ makePhrase $ "appear" : wown) c CEmbed lid _ -> markDisplayNeeded lid CFloor lid _ -> do itemVerbMU iid kit (MU.Text $ "appear" <+> ppContainer c) c markDisplayNeeded lid CTrunk{} -> error $ "" `showFailure` c stopPlayBack UpdDestroyItem iid _ kit c -> do itemVerbMU iid kit "disappear" c lid <- getsState $ lidFromC c markDisplayNeeded lid UpdSpotActor aid body _ -> createActorUI False aid body UpdLoseActor aid body _ -> destroyActorUI False aid body UpdSpotItem verbose2 iid _ kit c -> spotItem verbose2 iid kit c {- UpdLoseItem False _ _ _ _ -> return () -- The message is rather cryptic, so let's disable it until it's decided -- if anemy inventories should be displayed, etc. UpdLoseItem True iid _ kit c@(CActor aid store) | store /= CSha -> do -- Actor putting an item into shared stash, most probably. side <- getsClient sside b <- getsState $ getActorBody aid subject <- partActorLeader aid b let ownW = ppCStoreWownW store subject verb = MU.Text $ makePhrase $ "be removed from" : ownW when (bfid b == side) $ itemVerbMU iid kit verb c -} UpdLoseItem{} -> return () UpdSpotItemBag c bag _ -> mapWithKeyM_ (\iid kit -> spotItem True iid kit c) bag UpdLoseItemBag{} -> return () -- Move actors and items. UpdMoveActor aid source target -> moveActor 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. 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" b <- getsState $ getActorBody aid bUI <- getsSession $ getActorUI aid arena <- getArenaUI side <- getsClient sside if | bproj b && (EM.null (beqp b) || isNothing (btrajectory b)) -> return () -- ignore caught proj or one hitting a wall | bhp b <= 0 && n < 0 && (bfid b == side && not (bproj b) || arena == blid b) -> do let (firstFall, hurtExtra) = case (bfid b == side, bproj b) of (True, True) -> ("drop down", "tumble down") (True, False) -> ("fall down", "fall to pieces") (False, True) -> ("plummet", "crash") (False, False) -> ("collapse", "be reduced to a bloody pulp") verbDie = if alreadyDeadBefore then hurtExtra else firstFall alreadyDeadBefore = bhp b - n <= 0 subject <- partActorLeader aid bUI let msgDie = makeSentence [MU.SubjectVerbSg subject verbDie] msgAdd msgDie -- We show death anims only if not dead already before this refill. let deathAct | alreadyDeadBefore = twirlSplash (bpos b, bpos b) Color.Red Color.Red | bfid b == side = deathBody (bpos b) | otherwise = shortDeathBody (bpos b) unless (bproj b) $ animate (blid b) deathAct | otherwise -> do when (n >= bhp b && bhp b > 0) $ actorVerbMU aid bUI "return from the brink of death" mleader <- getsClient sleader when (Just aid == mleader) $ do ar <- getsState $ getActorAspect aid -- Regenerating actors never stop gaining HP, so we need to stop -- reporting it after they reach full HP for the first time. when (bhp b >= xM (IA.aMaxHP ar) && bhp b - n < xM (IA.aMaxHP ar)) $ do actorVerbMU aid bUI "recover your health fully" stopPlayBack UpdRefillCalm aid calmDelta -> when (calmDelta == minusM) $ do -- lower deltas come from hits; obvious side <- getsClient sside fact <- getsState $ (EM.! side) . sfactionD body <- getsState $ getActorBody aid when (bfid body == side) $ do let closeFoe !b = -- mimics isHeardFoe blid b == blid body && inline chessDist (bpos b) (bpos body) <= 3 && not (waitedLastTurn b) -- uncommon && inline isFoe side fact (bfid b) -- costly anyCloseFoes <- getsState $ any closeFoe . EM.elems . sactorD unless anyCloseFoes $ do -- obvious where the feeling comes from duplicated <- aidVerbDuplicateMU aid "hear something" unless duplicated stopPlayBack UpdTrajectory _ _ mt -> -- if projectile dies just after, force one frame when (maybe True (null . fst) mt) pushFrame -- Change faction attributes. UpdQuitFaction fid _ toSt -> quitFactionUI fid toSt UpdLeadFaction fid (Just source) (Just target) -> do fact <- getsState $ (EM.! fid) . sfactionD lidV <- viewedLevelUI when (isAIFact fact) $ markDisplayNeeded lidV -- This faction can't run with multiple actors, so this is not -- a leader change while running, but rather server changing -- their leader, which the player should be alerted to. when (noRunWithMulti fact) stopPlayBack actorD <- getsState sactorD case EM.lookup source actorD of Just sb | bhp sb <= 0 -> assert (not $ bproj sb) $ do -- Regardless who the leader is, give proper names here, not 'you'. sbUI <- getsSession $ getActorUI source tbUI <- getsSession $ getActorUI target let subject = partActor tbUI object = partActor sbUI msgAdd $ makeSentence [ MU.SubjectVerbSg subject "take command" , "from", object ] _ -> return () lookAtMove target UpdLeadFaction _ Nothing (Just target) -> lookAtMove target 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 lidV <- viewedLevelUI markDisplayNeeded lidV when (fid == side) $ setFrontAutoYes b UpdRecordKill{} -> return () -- Alter map. UpdAlterTile lid p fromTile toTile -> do markDisplayNeeded lid COps{cotile} <- getsState scops let feats = TK.tfeature $ okind cotile fromTile toAlter feat = case feat of TK.OpenTo tgroup -> Just tgroup TK.CloseTo tgroup -> Just tgroup TK.ChangeTo tgroup -> Just tgroup _ -> Nothing groupsToAlterTo = mapMaybe toAlter feats freq = map fst $ filter (\(_, q) -> q > 0) $ TK.tfreq $ okind cotile toTile when (null $ intersect freq groupsToAlterTo) $ do -- Player notices @fromTile can't be altered into @toTIle@, -- which is uncanny, so we produce a message. -- This happens when the player missed an earlier search of the tile -- performed by another faction. let subject = "" -- a hack, we we don't handle adverbs well verb = "turn into" msg = makeSentence [ "the", MU.Text $ TK.tname $ okind cotile fromTile , "at position", MU.Text $ tshow p , "suddenly" -- adverb , MU.SubjectVerbSg subject verb , MU.AW $ MU.Text $ TK.tname $ okind cotile toTile ] msgAdd msg UpdAlterExplorable lid _ -> markDisplayNeeded lid UpdAlterGold{} -> return () -- not displayed on HUD UpdSearchTile aid _p toTile -> do COps{cotile} <- getsState scops subject <- partAidLeader aid let fromTile = fromJust $ Tile.hideAs cotile toTile subject2 = MU.Text $ TK.tname $ okind cotile fromTile object = MU.Text $ TK.tname $ okind cotile toTile let msg = makeSentence [ MU.SubjectVerbSg subject "reveal" , "that the" , MU.SubjectVerbSg subject2 "be" , MU.AW object ] unless (subject2 == object) $ msgAdd msg UpdHideTile{} -> return () UpdSpotTile{} -> return () UpdLoseTile{} -> return () UpdAlterSmell{} -> return () UpdSpotSmell{} -> return () UpdLoseSmell{} -> return () -- Assorted. UpdTimeItem{} -> return () UpdAgeGame{} -> do sdisplayNeeded <- getsSession sdisplayNeeded when sdisplayNeeded pushFrame UpdUnAgeGame{} -> return () UpdDiscover c iid _ _ -> discover c iid UpdCover{} -> return () -- don't spam when doing undo UpdDiscoverKind{} -> return () -- don't spam when server tweaks stuff UpdCoverKind{} -> return () -- don't spam when doing undo UpdDiscoverAspect{} -> return () -- don't spam when server tweaks stuff UpdCoverAspect{} -> return () -- don't spam when doing undo UpdDiscoverServer{} -> error "server command leaked to client" UpdCoverServer{} -> error "server command leaked to client" UpdPerception{} -> return () UpdRestart fid _ _ _ _ -> do cops@COps{cocave} <- getsState scops sstart <- getsSession sstart when (sstart == 0) resetSessionStart history <- getsSession shistory if lengthHistory history == 0 then do let title = rtitle $ getStdRuleset cops msgAdd $ "Welcome to" <+> title <> "!" -- Generate initial history. Only for UI clients. sUIOptions <- getsSession sUIOptions shistory <- defaultHistory $ uHistoryMax sUIOptions modifySession $ \sess -> sess {shistory} else recordHistory lid <- getArenaUI lvl <- getLevel lid mode <- getGameMode curChal <- getsClient scurChal fact <- getsState $ (EM.! fid) . sfactionD let loneMode = case ginitial fact of [] -> True [(_, 1, _)] -> True _ -> False msgAdd $ "New game started in" <+> mname mode <+> "mode." <+> mdesc mode <+> cdesc (okind cocave $ lkind lvl) <+> if cwolf curChal && not loneMode then "Being a lone wolf, you start without companions." else "" when (lengthHistory history > 1) $ fadeOutOrIn False setFrontAutoYes $ isAIFact fact when (isAIFact fact) $ do -- Prod the frontend to flush frames and start showing them continuously. slides <- reportToSlideshow [] void $ getConfirms ColorFull [K.spaceKM, K.escKM] slides UpdRestartServer{} -> return () UpdResume fid _ -> do COps{cocave} <- getsState scops resetSessionStart fact <- getsState $ (EM.! fid) . sfactionD setFrontAutoYes $ isAIFact fact unless (isAIFact fact) $ do lid <- getArenaUI lvl <- getLevel lid mode <- getGameMode promptAdd0 $ "Continuing" <+> mname mode <> "." <+> mdesc mode <+> cdesc (okind cocave $ lkind lvl) <+> "Are you up for the challenge?" slides <- reportToSlideshow [K.spaceKM, K.escKM] km <- getConfirms ColorFull [K.spaceKM, K.escKM] slides if km == K.escKM then addPressedEsc else promptAdd0 "Prove yourself!" UpdResumeServer{} -> return () UpdKillExit{} -> frontendShutdown UpdWriteSave -> when verbose $ promptAdd1 "Saving backup." updateItemSlot :: MonadClientUI m => Container -> ItemId -> m () updateItemSlot c iid = do itemKind <- getsState $ getIidKind iid let slore = loreFromContainer itemKind c incrementPrefix l2 iid2 m = EM.insert l2 iid2 $ case EM.lookup l2 m of Nothing -> m Just iidOld -> let lNew = SlotChar (slotPrefix l2 + 1) (slotChar l2) in incrementPrefix lNew iidOld m slots@(ItemSlots itemSlots) <- getsSession sslots case lookup iid $ map swap $ EM.assocs $ itemSlots EM.! slore of Nothing -> do side <- getsClient sside mbody <- case c of CActor aid _ -> do b <- getsState $ getActorBody aid return $! if bfid b == side then Just b else Nothing _ -> return Nothing partySet <- getsState $ partyItemSet slore side mbody let l = assignSlot partySet slore slots newSlots = ItemSlots $ EM.adjust (incrementPrefix l iid) slore itemSlots modifySession $ \sess -> sess {sslots = newSlots} Just _l -> return () -- slot already assigned markDisplayNeeded :: MonadClientUI m => LevelId -> m () markDisplayNeeded lid = do lidV <- viewedLevelUI when (lidV == lid) $ modifySession $ \sess -> sess {sdisplayNeeded = True} lookAtMove :: MonadClientUI m => ActorId -> m () lookAtMove aid = do body <- getsState $ getActorBody aid side <- getsClient sside aimMode <- getsSession saimMode when (not (bproj body) && bfid body == side && isNothing aimMode) $ do -- aiming does a more extensive look itemsBlurb <- lookAtItems True (bpos body) aid msgAdd itemsBlurb fact <- getsState $ (EM.! bfid body) . sfactionD adjacentAssocs <- getsState $ actorAdjacentAssocs body if not (bproj body) && side == bfid body then do let foe (_, b2) = isFoe (bfid body) fact (bfid b2) adjFoes = filter foe adjacentAssocs unless (null adjFoes) stopPlayBack else when (isFoe (bfid body) fact side) $ do let our (_, b2) = not (bproj b2) && bfid b2 == side adjOur = filter our adjacentAssocs unless (null adjOur) stopPlayBack actorVerbMU :: MonadClientUI m => ActorId -> ActorUI -> MU.Part -> m () actorVerbMU aid bUI verb = do subject <- partActorLeader aid bUI msgAdd $ makeSentence [MU.SubjectVerbSg subject verb] aidVerbMU :: MonadClientUI m => ActorId -> MU.Part -> m () aidVerbMU aid verb = do bUI <- getsSession $ getActorUI aid actorVerbMU aid bUI verb aidVerbDuplicateMU :: MonadClientUI m => ActorId -> MU.Part -> m Bool aidVerbDuplicateMU aid verb = do bUI <- getsSession $ getActorUI aid subject <- partActorLeader aid bUI msgAddDuplicate $ makeSentence [MU.SubjectVerbSg subject 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 itemFull <- getsState $ itemToFull iid side <- getsClient sside factionD <- getsState sfactionD let (temporary, subject) = partItemWs side factionD k localTime itemFull kit msg | k > 1 && not temporary = makeSentence [MU.SubjectVerb MU.PlEtc MU.Yes subject verb] | otherwise = makeSentence [MU.SubjectVerbSg subject verb] msgAdd msg -- 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 body <- getsState $ getActorBody aid bag <- getsState $ getBodyStoreBag body cstore side <- getsClient sside factionD <- getsState sfactionD -- The item may no longer be in @c@, but it was case iid `EM.lookup` bag of Nothing -> error $ "" `showFailure` (aid, verb, iid, cstore) Just kit@(k, _) -> do itemFull <- getsState $ itemToFull iid let lid = blid body localTime <- getsState $ getLocalTime lid subject <- partAidLeader aid let object = case ek of Left (Just n) -> assert (n <= k `blame` (aid, verb, iid, cstore)) $ snd $ partItemWs side factionD n localTime itemFull kit Left Nothing -> let (_, _, name, stats) = partItem side factionD localTime itemFull kit in MU.Phrase [name, stats] Right n -> assert (n <= k `blame` (aid, verb, iid, cstore)) $ let (_, _, name1, stats) = partItemShort side factionD localTime itemFull kit name = if n == 1 then name1 else MU.CarWs n name1 in MU.Phrase ["the", name, stats] msg = makeSentence [MU.SubjectVerbSg subject verb, object] msgAdd msg createActorUI :: MonadClientUI m => Bool -> ActorId -> Actor -> m () createActorUI born aid body = do side <- getsClient sside factionD <- getsState sfactionD let fact = factionD EM.! bfid body globalTime <- getsState stime localTime <- getsState $ getLocalTime $ blid body itemFull@ItemFull{itemBase, itemKind} <- getsState $ itemToFull (btrunk body) let symbol = IK.isymbol itemKind mbUI <- getsSession $ EM.lookup aid . sactorUI bUI <- case mbUI of Just bUI -> return bUI Nothing -> do UIOptions{uHeroNames} <- getsSession sUIOptions let baseColor = flavourToColor $ jflavour itemBase basePronoun | not (bproj body) && fhasGender (gplayer fact) = "he" | otherwise = "it" nameFromNumber fn k = if k == 0 then makePhrase [MU.Ws $ MU.Text fn, "Captain"] else fn <+> tshow k heroNamePronoun k = if gcolor fact /= Color.BrWhite then (nameFromNumber (fname $ gplayer fact) k, "he") else fromMaybe (nameFromNumber (fname $ gplayer fact) k, "he") $ lookup k uHeroNames (n, bsymbol) <- if | bproj body -> return (0, if IK.isBlast itemKind then symbol else '*') | baseColor /= Color.BrWhite -> return (0, symbol) | otherwise -> do sactorUI <- getsSession sactorUI let hasNameK k bUI = bname bUI == fst (heroNamePronoun k) && bcolor bUI == gcolor fact findHeroK k = isJust $ find (hasNameK k) (EM.elems sactorUI) mhs = map findHeroK [0..] n = fromJust $ elemIndex False mhs return (n, if 0 < n && n < 10 then Char.intToDigit n else '@') let (bname, bpronoun) = if | bproj body -> let adj = case btrajectory body of Just (tra, _) | length tra < 5 -> "falling" _ -> "flying" -- Not much detail about a fast flying item. (_, _, object1, object2) = partItemShortest (bfid body) factionD localTime itemFull (1, []) in ( makePhrase [adj, object1, object2] , basePronoun ) | baseColor /= Color.BrWhite -> (IK.iname itemKind, basePronoun) | otherwise -> heroNamePronoun n bcolor | bproj body = if IK.isBlast itemKind then baseColor else Color.BrWhite | baseColor == Color.BrWhite = gcolor fact | otherwise = baseColor bUI = ActorUI{..} modifySession $ \sess -> sess {sactorUI = EM.insert aid bUI $ sactorUI sess} return bUI let verb = MU.Text $ if born then if globalTime == timeZero then "be here" else "appear" <+> if bfid body == side then "" else "suddenly" else "be spotted" mapM_ (\(iid, store) -> let c = if not (bproj body) && iid == btrunk body then CTrunk (bfid body) (blid body) (bpos body) else CActor aid store in void $ updateItemSlot c iid) ((btrunk body, CEqp) -- store will be overwritten, unless projectile : filter ((/= btrunk body) . fst) (getCarriedIidCStore body)) when (bfid body /= side) $ do when (not (bproj body) && isFoe (bfid body) fact side) $ -- Aim even if nobody can shoot at the enemy. Let's home in on him -- and then we can aim or melee. We set permit to False, because it's -- technically very hard to check aimability here, because we are -- in-between turns and, e.g., leader's move has not yet been taken -- into account. modifySession $ \sess -> sess {sxhair = 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 <- getsSession slastLost if ES.member aid lastLost || bproj body then markDisplayNeeded (blid body) else do actorVerbMU aid bUI verb animate (blid body) $ actorX (bpos body) destroyActorUI :: MonadClientUI m => Bool -> ActorId -> Actor -> m () destroyActorUI destroy aid b = do trunk <- getsState $ getItemBody $ btrunk b let baseColor = flavourToColor $ jflavour trunk unless (baseColor == Color.BrWhite) $ -- keep setup for heroes, etc. modifySession $ \sess -> sess {sactorUI = EM.delete aid $ sactorUI sess} let affect tgt = case tgt of TEnemy a permit | a == aid -> if destroy then -- If *really* nothing more interesting, the actor will -- go to last known location to perhaps find other foes. TPoint TAny (blid b) (bpos b) else -- If enemy only hides (or we stepped behind obstacle) find him. TPoint (TEnemyPos a permit) (blid b) (bpos b) _ -> tgt modifySession $ \sess -> sess {sxhair = affect $ sxhair sess} unless (bproj b) $ modifySession $ \sess -> sess {slastLost = ES.insert aid $ slastLost sess} side <- getsClient sside fact <- getsState $ (EM.! side) . sfactionD let gameOver = isJust $ gquit fact -- we are the UI faction, so we determine unless gameOver $ do when (bfid b == side && not (bproj b)) $ do stopPlayBack let upd = ES.delete aid modifySession $ \sess -> sess {sselected = upd $ sselected sess} when destroy $ do displayMore ColorBW "Alas!" mleader <- getsClient sleader when (isJust mleader) -- This is especially handy when the dead actor was a leader -- on a different level than the new one: clearAimMode -- If pushed, animate spotting again, to draw attention to pushing. markDisplayNeeded (blid b) spotItem :: MonadClientUI m => Bool -> ItemId -> ItemQuant -> Container -> m () spotItem verbose iid kit c = do -- This is due to a move, or similar, which will be displayed, -- so no extra @markDisplayNeeded@ needed here and in similar places. ItemSlots itemSlots <- getsSession sslots itemKind <- getsState $ getIidKind iid let slore = loreFromContainer itemKind c case lookup iid $ map swap $ EM.assocs $ itemSlots EM.! slore of Nothing -> do -- never seen or would have a slot void $ updateItemSlot c iid case c of CFloor lid p -> do sxhairOld <- getsSession sxhair case sxhairOld of TEnemy{} -> return () -- probably too important to overwrite TPoint TEnemyPos{} _ _ -> return () _ -> do -- Don't steal xhair if it's only an item on another level. -- For enemies, OTOH, capture xhair to alarm player. lidV <- viewedLevelUI when (lid == lidV) $ do bag <- getsState $ getFloorBag lid p modifySession $ \sess -> sess {sxhair = TPoint (TItem bag) lidV p} itemVerbMU iid kit "be located" c stopPlayBack _ -> return () _ -> return () -- this item or another with the same @iid@ -- seen already (has a slot assigned), so old news when verbose $ case c of CActor aid store | store `elem` [CEqp, CInv, CGround, CSha] -> do -- Actor fetching an item from or to shared stash, most probably. bUI <- getsSession $ getActorUI aid subject <- partActorLeader aid bUI let ownW = ppCStoreWownW False store subject verb = MU.Text $ makePhrase $ "be added to" : ownW itemVerbMU iid kit verb c _ -> return () moveActor :: MonadClientUI m => ActorId -> Point -> Point -> m () moveActor aid source target = do -- If source and target tile distant, assume it's a teleportation -- and display an animation. Note: jumps and pushes go through all -- intervening tiles, so won't be considered. Note: if source or target -- not seen, the (half of the) animation would be boring, just a delay, -- not really showing a transition, so we skip it (via 'breakUpdAtomic'). -- The message about teleportation is sometimes shown anyway, just as the X. body <- getsState $ getActorBody aid if adjacent source target then markDisplayNeeded (blid body) else do let ps = (source, target) animate (blid body) $ teleport ps lookAtMove aid displaceActorUI :: MonadClientUI m => ActorId -> ActorId -> m () displaceActorUI source target = do sb <- getsState $ getActorBody source sbUI <- getsSession $ getActorUI source tb <- getsState $ getActorBody target tbUI <- getsSession $ getActorUI target spart <- partActorLeader source sbUI tpart <- partActorLeader target tbUI let msg = makeSentence [MU.SubjectVerbSg spart "displace", tpart] msgAdd msg when (bfid sb /= bfid tb) $ do lookAtMove source lookAtMove target mleader <- getsClient sleader side <- getsClient sside -- Ours involved, but definitely not requested by player via UI. when (side `elem` [bfid sb, bfid tb] && mleader /= Just source) stopPlayBack let ps = (bpos tb, bpos sb) animate (blid sb) $ swapPlaces ps 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 ItemSlots itemSlots <- getsSession sslots case lookup iid $ map swap $ EM.assocs $ itemSlots EM.! SItem of Just _l -> -- So far organs can't be put into backpack, so no need to call -- @updateItemSlot@ to add or reassign lore category. if cstore1 == CGround && Just aid == mleader && not underAI then itemAidVerbMU aid (MU.Text verb) iid (Right k) cstore2 else when (not (bproj b) && bhp b > 0) $ -- don't announce death drops itemAidVerbMU aid (MU.Text verb) iid (Left $ Just k) cstore2 Nothing -> error $ "" `showFailure` (iid, k, aid, cstore1, cstore2) quitFactionUI :: MonadClientUI m => FactionId -> Maybe Status -> m () quitFactionUI fid toSt = do COps{coitem} <- getsState scops fact <- getsState $ (EM.! fid) . sfactionD let fidName = MU.Text $ gname fact person = if fhasGender $ gplayer fact then MU.PlEtc else MU.Sg3rd horror = isHorrorFact fact side <- getsClient sside when (side == fid && maybe False ((/= Camping) . stOutcome) toSt) $ do let won = case toSt of Just Status{stOutcome=Conquer} -> True Just Status{stOutcome=Escape} -> True _ -> False when won $ do gameModeId <- getsState sgameModeId scurChal <- getsClient scurChal let sing = M.singleton scurChal 1 f = M.unionWith (+) g = EM.insertWith f gameModeId sing modifyClient $ \cli -> cli {svictories = g $ svictories cli} tellGameClipPS resetGameStart let msgIfSide _ | fid /= side = Nothing msgIfSide s = Just s (startingPart, partingPart) = case toSt of _ | horror -> -- Ignore summoned actors' factions. (Nothing, Nothing) 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} -> error $ "" `showFailure` (fid, toSt) Nothing -> (Nothing, Nothing) -- server wipes out Camping for savefile case startingPart of Nothing -> return () Just sp -> msgAdd $ makeSentence [MU.SubjectVerb person MU.Yes fidName sp] case (toSt, partingPart) of (Just status, Just pp) -> do isNoConfirms <- isNoConfirmsGame go <- if isNoConfirms && fmap stOutcome toSt /= Just Camping then return False else displaySpaceEsc ColorFull "" when (side == fid) recordHistory -- we are going to exit or restart, so record and clear, but only once when go $ do lidV <- viewedLevelUI Level{lxsize, lysize} <- getLevel lidV revCmd <- revCmdMap let currencyName = MU.Text $ IK.iname $ okind coitem $ ouniqGroup coitem "currency" caretKey = revCmd (K.KM K.NoModifier $ K.Char '^') HumanCmd.SortSlots keysPre = [K.spaceKM, caretKey, K.escKM] arena <- getArenaUI (itemBag, total) <- getsState $ calculateTotal side localTime <- getsState $ getLocalTime arena factionD <- getsState sfactionD let examItem slotIndex = do ItemSlots itemSlots <- getsSession sslots let lSlots = EM.filter (`EM.member` itemBag) $ itemSlots EM.! SItem lSlotsElems = EM.elems lSlots lSlotsBound = length lSlotsElems - 1 iid2 = lSlotsElems !! slotIndex kit2@(k, _) = itemBag EM.! iid2 itemFull2 <- getsState $ itemToFull iid2 let attrLine = itemDesc True side factionD 0 CGround localTime itemFull2 kit2 ov = splitAttrLine lxsize attrLine keys = [K.spaceKM, K.escKM] ++ [K.upKM | slotIndex /= 0] ++ [K.downKM | slotIndex /= lSlotsBound] let worth = itemPrice 1 $ itemKind itemFull2 lootMsg | worth /= 0 = makeSentence $ ["this particular loot is worth"] ++ (if k > 1 then [ MU.Cardinal k, "times"] else []) ++ [MU.CarWs worth currencyName] | otherwise = makeSentence ["this item is not worth any", MU.Ws currencyName] promptAdd0 lootMsg slides <- overlayToSlideshow (lysize + 1) keys (ov, []) km <- getConfirms ColorFull keys slides case K.key km of K.Space -> return True K.Up -> examItem (slotIndex - 1) K.Down -> examItem (slotIndex + 1) K.Esc -> return False _ -> error $ "" `showFailure` km viewItems = if EM.null itemBag then return True else do dungeonTotal <- getsState sgold let spoilsMsg = if | dungeonTotal == 0 -> "All your spoils are of the practical kind." | total == 0 -> "You haven't found any genuine treasure." | otherwise -> makeSentence [ "your spoils are worth" , MU.CarWs total currencyName , "out of the rumoured total" , MU.CarWs dungeonTotal currencyName ] promptAdd0 spoilsMsg ItemSlots itemSlots <- getsSession sslots let lSlots = EM.filter (`EM.member` itemBag) $ itemSlots EM.! SItem io <- itemOverlay lSlots arena itemBag itemSlides <- overlayToSlideshow (lysize + 1) keysPre io let keyOfEKM (Left km) = km keyOfEKM (Right SlotChar{slotChar}) = [K.mkChar slotChar] allOKX = concatMap snd $ slideshow itemSlides keysMain = keysPre ++ concatMap (keyOfEKM . fst) allOKX ekm <- displayChoiceScreen "quit loot" ColorFull False itemSlides keysMain case ekm of Left km | km == K.spaceKM -> return True Left km | km == caretKey -> do sortSlots fid Nothing viewItems Left km | km == K.escKM -> return False Left _ -> error $ "" `showFailure` ekm Right slot -> do let ix0 = fromJust $ findIndex (== slot) $ EM.keys lSlots go2 <- examItem ix0 if go2 then viewItems else return True go3 <- viewItems when go3 $ do unless isNoConfirms $ do -- Show score for any UI client after any kind of game exit, -- even though it is saved only for human UI clients at game over -- (that is not a noConfirms or benchmark game). scoreSlides <- scoreToSlideshow total status void $ getConfirms ColorFull [K.spaceKM, K.escKM] scoreSlides -- The last prompt stays onscreen during shutdown, etc. promptAdd0 pp partingSlide <- reportToSlideshow [K.spaceKM, K.escKM] void $ getConfirms ColorFull [K.spaceKM, K.escKM] partingSlide unless (fmap stOutcome toSt == Just Camping) $ fadeOutOrIn True _ -> return () discover :: MonadClientUI m => Container -> ItemId -> m () discover c iid = do COps{coitem} <- getsState scops lid <- getsState $ lidFromC c globalTime <- getsState stime localTime <- getsState $ getLocalTime lid itemFull <- getsState $ itemToFull iid bag <- getsState $ getContainerBag c side <- getsClient sside factionD <- getsState sfactionD (isOurOrgan, nameWhere) <- case c of CActor aidOwner storeOwner -> do bOwner <- getsState $ getActorBody aidOwner bOwnerUI <- getsSession $ getActorUI aidOwner let name = if bproj bOwner || bfid bOwner == side then [] else ppCStoreWownW True storeOwner (partActor bOwnerUI) return (bfid bOwner == side && storeOwner == COrgan, name) _ -> return (False, []) let kit = EM.findWithDefault (1, []) iid bag knownName = partItemMediumAW side factionD localTime itemFull kit -- Make sure the two names in the message differ. name = IK.iname $ okind coitem $ case jkind $ itemBase itemFull of IdentityObvious ik -> ik IdentityCovered _ix ik -> ik -- fake kind; we talk about appearances flav = flavourToName $ jflavour $ itemBase itemFull unknownName = MU.Phrase $ [MU.Text flav, MU.Text name] ++ nameWhere msg = makeSentence ["the", MU.SubjectVerbSg unknownName "turn out to be", knownName] -- Compare descriptions of all aspects and effects to determine -- if the discovery was meaningful to the player. unless (globalTime == timeZero -- don't spam about initial equipment || isOurOrgan) $ -- assume own faction organs known intuitively msgAdd msg -- * RespSfxAtomicUI -- | Display special effects (text, animation) sent to the client. displayRespSfxAtomicUI :: MonadClientUI m => Bool -> SfxAtomic -> m () {-# INLINE displayRespSfxAtomicUI #-} displayRespSfxAtomicUI verbose sfx = case sfx of SfxStrike source target iid store -> strike False source target iid store SfxRecoil source target _ _ -> do spart <- partAidLeader source tpart <- partAidLeader target msgAdd $ makeSentence [MU.SubjectVerbSg spart "shrink away from", tpart] SfxSteal source target iid store -> strike True source target iid store SfxRelease source target _ _ -> do spart <- partAidLeader source tpart <- partAidLeader target msgAdd $ makeSentence [MU.SubjectVerbSg spart "release", tpart] SfxProject aid iid cstore -> itemAidVerbMU aid "fling" iid (Left $ Just 1) cstore SfxReceive aid iid cstore -> itemAidVerbMU aid "receive" iid (Left $ Just 1) cstore SfxApply aid iid cstore -> do ItemFull{itemKind} <- getsState $ itemToFull iid let action = case IK.isymbol itemKind of '!' -> "imbibe" '?' -> "peruse" _ -> "use" itemAidVerbMU aid action iid (Left $ Just 1) cstore SfxCheck aid iid cstore -> itemAidVerbMU aid "deapply" iid (Left $ Just 1) cstore SfxTrigger aid _p -> -- So far triggering is visible, e.g., doors close, so no need for messages. when verbose $ aidVerbMU aid "trigger" SfxShun aid _p -> when verbose $ aidVerbMU aid "shun" SfxEffect fidSource aid effect hpDelta -> do b <- getsState $ getActorBody aid bUI <- getsSession $ getActorUI aid side <- getsClient sside mleader <- getsClient sleader let fid = bfid b isOurCharacter = fid == side && not (bproj b) isOurAlive = isOurCharacter && bhp b > 0 isOurLeader = Just aid == mleader case effect of IK.Burn{} | bproj b -> return () IK.Burn{} -> do if isOurAlive then actorVerbMU aid bUI "feel burned" else actorVerbMU aid bUI "look burned" let ps = (bpos b, bpos b) animate (blid b) $ twirlSplash ps Color.BrRed Color.Brown IK.Explode{} -> return () -- lots of visual feedback IK.RefillHP{} | bproj b -> return () IK.RefillHP p | p == 1 -> return () -- no spam from regeneration IK.RefillHP p | p == -1 -> return () -- no spam from poison IK.RefillHP{} | hpDelta > 0 -> do if isOurAlive then actorVerbMU aid bUI "feel healthier" else actorVerbMU aid bUI "look healthier" let ps = (bpos b, bpos b) animate (blid b) $ twirlSplash ps Color.BrGreen Color.Green IK.RefillHP{} -> do if isOurAlive then actorVerbMU aid bUI "feel wounded" else actorVerbMU aid bUI "look wounded" let ps = (bpos b, bpos b) animate (blid b) $ twirlSplash ps Color.BrRed Color.Red IK.RefillCalm{} | bproj b -> return () IK.RefillCalm p | p == 1 -> return () -- no spam from regen items IK.RefillCalm p | p > 0 -> if isOurAlive then actorVerbMU aid bUI "feel calmer" else actorVerbMU aid bUI "look calmer" IK.RefillCalm _ -> if isOurAlive then actorVerbMU aid bUI "feel agitated" else actorVerbMU aid bUI "look agitated" IK.Dominate | bproj b -> return () IK.Dominate -> do -- For subsequent messages use the proper name, never "you". let subject = partActor bUI if fid /= fidSource then do -- Before domination, possibly not seen if actor (yet) not ours. if | bcalm b == 0 -> -- sometimes only a coincidence, but nm aidVerbMU aid $ MU.Text "yield, under extreme pressure" | isOurAlive -> aidVerbMU aid $ MU.Text "black out, dominated by foes" | otherwise -> 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 isOurAlive $ displayMoreKeep ColorFull "" else do -- After domination, possibly not seen, if actor (already) not ours. fidSourceName <- getsState $ gname . (EM.! fidSource) . sfactionD let verb = "be now under" msgAdd $ makeSentence [MU.SubjectVerbSg subject verb, MU.Text fidSourceName, "control"] stopPlayBack IK.Impress -> actorVerbMU aid bUI "be awestruck" IK.Summon grp p -> do let verb = if bproj b then "lure" else "summon" object = (if p == 1 -- works, because exact number sent, not dice then MU.AW else MU.Ws) $ MU.Text $ tshow grp actorVerbMU aid bUI $ MU.Phrase [verb, object] IK.Ascend up -> do COps{cocave} <- getsState scops actorVerbMU aid bUI $ MU.Text $ "find a way" <+> if up then "upstairs" else "downstairs" when isOurLeader $ do (lid, _) <- getsState $ whereTo (blid b) (bpos b) (Just up) . sdungeon lvl <- getLevel lid msgAdd $ cdesc $ okind cocave $ lkind lvl IK.Escape{} -> return () IK.Paralyze{} | bproj b -> return () IK.Paralyze{} -> actorVerbMU aid bUI "be paralyzed" IK.InsertMove{} | bproj b -> return () IK.InsertMove{} -> actorVerbMU aid bUI "act with extreme speed" IK.Teleport t | Dice.maxDice t <= 9 -> actorVerbMU aid bUI "blink" IK.Teleport{} -> actorVerbMU aid bUI "teleport" IK.CreateItem{} -> return () IK.DropItem{} | bproj b -> return () IK.DropItem _ _ COrgan _ -> return () IK.DropItem{} -> actorVerbMU aid bUI "be stripped" IK.PolyItem -> do subject <- partActorLeader aid bUI let ppstore = MU.Text $ ppCStoreIn CGround msgAdd $ makeSentence [MU.SubjectVerbSg subject "repurpose", "what lies", ppstore] IK.Identify -> do subject <- partActorLeader aid bUI pronoun <- partPronounLeader aid bUI msgAdd $ makeSentence [ MU.SubjectVerbSg subject "look at" , MU.WownW pronoun $ MU.Text "inventory" , "intensely" ] IK.Detect d _ -> do subject <- partActorLeader aid bUI let verb = MU.Text $ detectToVerb d object = MU.Ws $ MU.Text $ detectToObject d msgAdd $ makeSentence [MU.SubjectVerbSg subject verb, object] displayMore ColorFull "" IK.SendFlying{} | bproj b -> return () IK.SendFlying{} -> actorVerbMU aid bUI "be sent flying" IK.PushActor{} | bproj b -> return () IK.PushActor{} -> actorVerbMU aid bUI "be pushed" IK.PullActor{} | bproj b -> return () IK.PullActor{} -> actorVerbMU aid bUI "be pulled" IK.DropBestWeapon | bproj b -> return () IK.DropBestWeapon -> actorVerbMU aid bUI "be disarmed" IK.ActivateInv{} -> return () IK.ApplyPerfume -> msgAdd "The fragrance quells all scents in the vicinity." IK.OneOf{} -> return () IK.OnSmash{} -> error $ "" `showFailure` sfx IK.Recharging{} -> error $ "" `showFailure` sfx IK.Temporary t -> actorVerbMU aid bUI $ MU.Text t IK.Composite{} -> error $ "" `showFailure` sfx SfxMsgFid _ sfxMsg -> do mleader <- getsClient sleader case mleader of Just{} -> return () -- will display stuff when leader moves Nothing -> do lidV <- viewedLevelUI markDisplayNeeded lidV recordHistory msg <- ppSfxMsg sfxMsg msgAdd msg SfxSortSlots -> do side <- getsClient sside sortSlots side Nothing SfxCollideTile source pos -> do COps{cotile} <- getsState scops sb <- getsState $ getActorBody source lvl <- getLevel $ blid sb sbUI <- getsSession $ getActorUI source spart <- partActorLeader source sbUI let object = MU.AW $ MU.Text $ TK.tname $ okind cotile $ lvl `at` pos msgAdd $! makeSentence [MU.SubjectVerbSg spart "painfully collide", "with", object] ppSfxMsg :: MonadClientUI m => SfxMsg -> m Text ppSfxMsg sfxMsg = case sfxMsg of SfxUnexpected reqFailure -> return $! "Unexpected problem:" <+> showReqFailure reqFailure <> "." SfxExpected itemName reqFailure -> return $! "The" <+> itemName <+> "is not triggered:" <+> showReqFailure reqFailure <> "." SfxLoudUpd local cmd -> do COps{coTileSpeedup} <- getsState scops let sound = case cmd of UpdDestroyActor{} -> "shriek" UpdCreateItem{} -> "clatter" UpdTrajectory{} -> -- Projectile hits an non-walkable tile on leader's level. "thud" UpdAlterTile _ _ fromTile _ -> if Tile.isDoor coTileSpeedup fromTile then "creaking sound" else "rumble" UpdAlterExplorable _ k -> if k > 0 then "grinding noise" else "fizzing noise" _ -> error $ "" `showFailure` cmd distant = if local then [] else ["distant"] msg = makeSentence [ "you hear" , MU.AW $ MU.Phrase $ distant ++ [sound] ] return $! msg SfxLoudStrike local ik distance -> do COps{coitem} <- getsState scops let verb = IK.iverbHit $ okind coitem ik adverb = if | distance < 5 -> "loudly" | distance < 10 -> "distinctly" | distance < 40 -> "" -- most common | distance < 45 -> "faintly" | otherwise -> "barely" -- 50 is the hearing limit distant = if local then [] else ["far away"] msg = makeSentence $ [ "you", adverb, "hear something", verb, "someone"] ++ distant return $! msg SfxLoudSummon isProj grp p -> do let verb = if isProj then "something lure" else "somebody summon" object = if p == 1 -- works, because exact number sent, not dice then MU.Text $ tshow grp else MU.Ws $ MU.Text $ tshow grp return $! makeSentence ["you hear", verb, object] SfxFizzles -> return "It didn't work." SfxNothingHappens -> return "Nothing happens." SfxVoidDetection d -> do let object = detectToObject d noNewObject | T.null object = ["nothing new"] | otherwise = ["no new", MU.Text object] return $! makeSentence $ noNewObject ++ ["detected"] SfxUnimpressed aid -> do msbUI <- getsSession $ EM.lookup aid . sactorUI case msbUI of Nothing -> return "" Just sbUI -> do let subject = partActor sbUI verb = "be unimpressed" return $! makeSentence [MU.SubjectVerbSg subject verb] SfxSummonLackCalm aid -> do msbUI <- getsSession $ EM.lookup aid . sactorUI case msbUI of Nothing -> return "" Just sbUI -> do let subject = partActor sbUI verb = "lack Calm to summon" return $! makeSentence [MU.SubjectVerbSg subject verb] SfxLevelNoMore -> return "No more levels in this direction." SfxLevelPushed -> return "You notice somebody pushed to another level." SfxBracedImmune aid -> do msbUI <- getsSession $ EM.lookup aid . sactorUI case msbUI of Nothing -> return "" Just sbUI -> do let subject = partActor sbUI verb = "be braced and so immune to translocation" return $! makeSentence [MU.SubjectVerbSg subject verb] SfxEscapeImpossible -> return "Escaping outside is unthinkable for members of this faction." SfxStasisProtects -> return "Paralysis and speed surge require recovery time." SfxTransImpossible -> return "Translocation not possible." SfxIdentifyNothing -> return "Nothing to identify." SfxPurposeNothing store -> return $! "The purpose of repurpose cannot be availed without an item" <+> ppCStoreIn store <> "." SfxPurposeTooFew maxCount itemK -> return $! "The purpose of repurpose is served by" <+> tshow maxCount <+> "pieces of this item, not by" <+> tshow itemK <> "." SfxPurposeUnique -> return "Unique items can't be repurposed." SfxPurposeNotCommon -> return "Only ordinary common items can be repurposed." SfxColdFish -> return "Healing attempt from another faction is thwarted by your cold fish attitude." SfxTimerExtended lid aid iid cstore -> do aidSeen <- getsState $ memActor aid lid if aidSeen then do b <- getsState $ getActorBody aid bUI <- getsSession $ getActorUI aid aidPhrase <- partActorLeader aid bUI factionD <- getsState sfactionD localTime <- getsState $ getLocalTime (blid b) itemFull <- getsState $ itemToFull iid let kit = (1, []) (_, _, name, stats) = partItem (bfid b) factionD localTime itemFull kit storeOwn = ppCStoreWownW True cstore aidPhrase cond = ["condition" | IK.isTmpCondition $ itemKind itemFull] return $! makeSentence $ ["the", name, stats] ++ cond ++ storeOwn ++ ["will now last longer"] else return "" SfxCollideActor lid source target -> do sourceSeen <- getsState $ memActor source lid targetSeen <- getsState $ memActor target lid if sourceSeen && targetSeen then do sbUI <- getsSession $ getActorUI source tbUI <- getsSession $ getActorUI target spart <- partActorLeader source sbUI tpart <- partActorLeader target tbUI return $! makeSentence [MU.SubjectVerbSg spart "painfully collide", "with", tpart] else return "" strike :: MonadClientUI m => Bool -> ActorId -> ActorId -> ItemId -> CStore -> m () strike catch source target iid cstore = assert (source /= target) $ do tb <- getsState $ getActorBody target tbUI <- getsSession $ getActorUI target sourceSeen <- getsState $ memActor source (blid tb) (ps, hurtMult, dmg) <- if sourceSeen then do hurtMult <- getsState $ armorHurtBonus source target itemFull@ItemFull{itemKind} <- getsState $ itemToFull iid sb <- getsState $ getActorBody source sbUI <- getsSession $ getActorUI source spart <- partActorLeader source sbUI tpart <- partActorLeader target tbUI spronoun <- partPronounLeader source sbUI localTime <- getsState $ getLocalTime (blid tb) bag <- getsState $ getBodyStoreBag sb cstore side <- getsClient sside factionD <- getsState sfactionD let kit = EM.findWithDefault (1, []) iid bag verb = if catch then "catch" else IK.iverbHit itemKind partItemChoice = if iid `EM.member` borgan sb then partItemShortWownW side factionD spronoun localTime else partItemShortAW side factionD localTime subtly = if IK.idamage itemKind == 0 && not (bproj sb) then "delicately" else "" msg | bhp tb <= 0 -- incapacitated, so doesn't actively block || hurtMult > 90 -- at most minor armor || bproj sb && bproj tb -- too much spam when explosions collide || IK.idamage itemKind == 0 = makeSentence $ [MU.SubjectVerbSg spart verb, tpart, subtly] ++ if bproj sb then [] else ["with", partItemChoice itemFull kit] | otherwise = -- 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 verb, tpart , "with", partItemChoice itemFull kit ] actionPhrase = MU.SubjectVerbSg tpart $ if bproj sb then if braced tb then "deflect it" else "fend it off" -- ward it off else if braced tb then "block" -- parry else "dodge" -- evade butEvenThough = if catch then ", even though" else ", but" in makeSentence [ MU.Phrase sActs <> butEvenThough , actionPhrase , if | hurtMult >= 50 -> -- braced or big bonuses "partly" | hurtMult > 1 -> -- braced and/or huge bonuses if braced tb then "doggedly" else "nonchalantly" | otherwise -> -- 1% got through, which can "almost completely" -- still be deadly, if fast missile ] msgAdd msg return ((bpos tb, bpos sb), hurtMult, IK.idamage itemKind) else return ((bpos tb, bpos tb), 100, 1) let anim | dmg == 0 = subtleHit $ snd ps | hurtMult > 90 = twirlSplash ps Color.BrRed Color.Red | hurtMult > 1 = blockHit ps Color.BrRed Color.Red | otherwise = blockMiss ps animate (blid tb) anim LambdaHack-0.8.3.0/Game/LambdaHack/Client/UI/Slideshow.hs0000644000000000000000000001201713315545734020700 0ustar0000000000000000-- | Slideshows. module Game.LambdaHack.Client.UI.Slideshow ( KYX, OKX, Slideshow(slideshow) , emptySlideshow, unsnoc, toSlideshow, menuToSlideshow , wrapOKX, splitOverlay, splitOKX #ifdef EXPOSE_INTERNAL -- * Internal operations , moreMsg, endMsg, keysOKX #endif ) where import Prelude () import Game.LambdaHack.Common.Prelude import Game.LambdaHack.Client.UI.ItemSlot import qualified Game.LambdaHack.Client.UI.Key as K import Game.LambdaHack.Client.UI.Msg import Game.LambdaHack.Client.UI.Overlay import qualified Game.LambdaHack.Common.Color as Color import Game.LambdaHack.Common.Point -- | A key or an item slot label at a given position on the screen. type KYX = (Either [K.KM] SlotChar, (Y, X, X)) -- | An Overlay of text with an associated list of keys or slots -- that activated when the specified screen position is pointed at. -- The list should be sorted wrt rows and then columns. type OKX = (Overlay, [KYX]) -- | A list of active screenfulls to be shown one after another. -- Each screenful has an independent numbering of rows and columns. newtype Slideshow = Slideshow {slideshow :: [OKX]} deriving (Show, Eq) emptySlideshow :: Slideshow emptySlideshow = Slideshow [] unsnoc :: Slideshow -> Maybe (Slideshow, OKX) unsnoc Slideshow{slideshow} = case reverse slideshow of [] -> Nothing okx : rest -> Just (Slideshow $ reverse rest, okx) toSlideshow :: [OKX] -> Slideshow toSlideshow okxs = Slideshow $ addFooters False okxsNotNull where okxFilter (ov, kyxs) = (ov, filter (either (not . null) (const True) . fst) kyxs) okxsNotNull = map okxFilter okxs addFooters _ [] = error $ "" `showFailure` okxsNotNull addFooters _ [(als, [])] = [( als ++ [stringToAL endMsg] , [(Left [K.safeSpaceKM], (length als, 0, 15))] )] addFooters False [(als, kxs)] = [(als, kxs)] addFooters True [(als, kxs)] = [( als ++ [stringToAL endMsg] , kxs ++ [(Left [K.safeSpaceKM], (length als, 0, 15))] )] addFooters _ ((als, kxs) : rest) = ( als ++ [stringToAL moreMsg] , kxs ++ [(Left [K.safeSpaceKM], (length als, 0, 8))] ) : addFooters True rest moreMsg :: String moreMsg = "--more-- " endMsg :: String endMsg = "--back to top-- " menuToSlideshow :: OKX -> Slideshow menuToSlideshow (als, kxs) = assert (not (null als || null kxs)) $ Slideshow [(als, kxs)] wrapOKX :: Y -> X -> X -> [(K.KM, String)] -> OKX wrapOKX ystart xstart xBound ks = let f ((y, x), (kL, kV, kX)) (key, s) = let len = length s in if x + len > xBound then f ((y + 1, 0), ([], kL : kV, kX)) (key, s) else ( (y, x + len + 1) , (s : kL, kV, (Left [key], (y, x, x + len)) : kX) ) (kL1, kV1, kX1) = snd $ foldl' f ((ystart, xstart), ([], [], [])) ks catL = stringToAL . intercalate " " . reverse in (reverse $ map catL $ kL1 : kV1, reverse kX1) keysOKX :: Y -> X -> X -> [K.KM] -> OKX keysOKX ystart xstart xBound keys = let wrapB :: String -> String wrapB s = "[" ++ s ++ "]" ks = map (\key -> (key, wrapB $ K.showKM key)) keys in wrapOKX ystart xstart xBound ks splitOverlay :: X -> Y -> Report -> [K.KM] -> OKX -> Slideshow splitOverlay lxsize yspace report keys (ls0, kxs0) = toSlideshow $ splitOKX lxsize yspace (renderReport report) keys (ls0, kxs0) splitOKX :: X -> Y -> AttrLine -> [K.KM] -> OKX -> [OKX] splitOKX lxsize yspace rrep keys (ls0, kxs0) = assert (yspace > 2) $ -- and kxs0 is sorted let msgRaw = splitAttrLine lxsize rrep (lX0, keysX0) = keysOKX 0 0 maxBound keys (lX, keysX) | null msgRaw = (lX0, keysX0) | otherwise = keysOKX (length msgRaw - 1) (length (last msgRaw) + 1) lxsize keys msgOkx = (glueLines msgRaw lX, keysX) ((lsInit, kxsInit), (header, rkxs)) = -- Check whether most space taken by report and keys. if length (glueLines msgRaw lX0) * 2 > yspace then (msgOkx, ( [intercalate [Color.spaceAttrW32] lX0 <+:> rrep] , keysX0 )) -- will display "$" (unless has EOLs) else (([], []), msgOkx) renumber y (km, (y0, x1, x2)) = (km, (y0 + y, x1, x2)) splitO yoffset (hdr, rk) (ls, kxs) = let zipRenumber = map $ renumber $ length hdr - yoffset (pre, post) = splitAt (yspace - 1) $ hdr ++ ls yoffsetNew = yoffset + yspace - length hdr - 1 in if null post then [(pre, rk ++ zipRenumber kxs)] -- all fits on one screen else let (preX, postX) = break (\(_, (y1, _, _)) -> y1 >= yoffsetNew) kxs in (pre, rk ++ zipRenumber preX) : splitO yoffsetNew (hdr, rk) (post, postX) initSlides = if null lsInit then assert (null kxsInit) [] else splitO 0 ([], []) (lsInit, kxsInit) mainSlides = if null ls0 && not (null lsInit) then assert (null kxs0) [] else splitO 0 (header, rkxs) (ls0, kxs0) in initSlides ++ mainSlides LambdaHack-0.8.3.0/Game/LambdaHack/Client/UI/Frontend.hs0000644000000000000000000001741513315545734020525 0ustar0000000000000000{-# LANGUAGE GADTs, KindSignatures, RankNTypes #-} -- | Display game data on the screen and receive user input -- using one of the available raw frontends and derived operations. module Game.LambdaHack.Client.UI.Frontend ( -- * Connection and initialization FrontReq(..), ChanFrontend(..), chanFrontendIO -- * Re-exported part of the raw frontend , frontendName #ifdef EXPOSE_INTERNAL -- * Internal operations , FrontSetup, getKey, fchanFrontend, display, defaultMaxFps, microInSec , frameTimeoutThread, lazyStartup, nullStartup, seqFrame #endif ) where import Prelude () import Game.LambdaHack.Common.Prelude import Control.Concurrent import Control.Concurrent.Async import qualified Control.Concurrent.STM as STM import Control.Monad.ST.Strict import Data.IORef import qualified Data.Vector.Generic as G import qualified Data.Vector.Unboxed as U import qualified Data.Vector.Unboxed.Mutable as VM import Data.Word import Game.LambdaHack.Client.ClientOptions import Game.LambdaHack.Client.UI.Frame import qualified Game.LambdaHack.Client.UI.Frontend.Chosen as Chosen import Game.LambdaHack.Client.UI.Frontend.Common import qualified Game.LambdaHack.Client.UI.Frontend.Teletype as Teletype import Game.LambdaHack.Client.UI.Key (KMP (..)) import qualified Game.LambdaHack.Client.UI.Key as K import qualified Game.LambdaHack.Common.Color as Color import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.Point import qualified Game.LambdaHack.Common.PointArray as PointArray -- | The instructions sent by clients to the raw frontend, indexed -- by the returned value. data FrontReq :: * -> * where -- | Show a frame. FrontFrame :: {frontFrame :: FrameForall} -> FrontReq () -- | Perform an explicit delay of the given length. FrontDelay :: Int -> FrontReq () -- | Flush frames, display a frame and ask for a keypress. FrontKey :: { frontKeyKeys :: [K.KM] , frontKeyFrame :: FrameForall } -> FrontReq KMP -- | Tell if a keypress is pending. FrontPressed :: FrontReq Bool -- | Discard a key in the queue, if any. FrontDiscard :: FrontReq () -- | Add a key to the queue. FrontAdd :: KMP -> FrontReq () -- | Set in the frontend that it should auto-answer prompts. FrontAutoYes :: Bool -> FrontReq () -- | Shut the frontend down. FrontShutdown :: FrontReq () -- | Take screenshot. FrontPrintScreen :: FrontReq () -- | Connection channel between a frontend and a client. Frontend acts -- as a server, serving keys, etc., when given frames to display. newtype ChanFrontend = ChanFrontend (forall a. FrontReq a -> IO a) -- | Machinery allocated for an individual frontend at its startup, -- unchanged for its lifetime. data FrontSetup = FrontSetup { fautoYesRef :: IORef Bool , fasyncTimeout :: Async () , fdelay :: MVar Int } -- | Initialize the frontend chosen by the player via client options. chanFrontendIO :: ClientOptions -> IO ChanFrontend chanFrontendIO soptions = do let startup | sfrontendNull soptions = nullStartup | sfrontendLazy soptions = lazyStartup | sfrontendTeletype soptions = Teletype.startup soptions | otherwise = Chosen.startup soptions maxFps = fromMaybe defaultMaxFps $ smaxFps soptions delta = max 1 $ microInSec `div` maxFps rf <- startup fautoYesRef <- newIORef $ not $ sdisableAutoYes soptions fdelay <- newMVar 0 fasyncTimeout <- async $ frameTimeoutThread delta fdelay rf -- Warning: not linking @fasyncTimeout@, so it'd better not crash. let fs = FrontSetup{..} return $ fchanFrontend soptions fs rf -- Display a frame, wait for any of the specified keys (for any key, -- if the list is empty). Repeat if an unexpected key received. getKey :: ClientOptions -> FrontSetup -> RawFrontend -> [K.KM] -> FrameForall -> IO KMP getKey soptions fs rf@RawFrontend{fchanKey} keys frame = do autoYes <- readIORef $ fautoYesRef fs if autoYes && (null keys || K.spaceKM `elem` keys) then do display rf frame return $! KMP{kmpKeyMod = K.spaceKM, kmpPointer=originPoint} else do -- Wait until timeout is up, not to skip the last frame of animation. display rf frame kmp <- STM.atomically $ STM.readTQueue fchanKey if null keys || kmpKeyMod kmp `elem` keys then return kmp else getKey soptions fs rf keys frame -- Read UI requests from the client and send them to the frontend, fchanFrontend :: ClientOptions -> FrontSetup -> RawFrontend -> ChanFrontend fchanFrontend soptions fs@FrontSetup{..} rf = ChanFrontend $ \case FrontFrame{..} -> display rf frontFrame FrontDelay k -> modifyMVar_ fdelay $ return . (+ k) FrontKey{..} -> getKey soptions fs rf frontKeyKeys frontKeyFrame FrontPressed -> do noKeysPending <- STM.atomically $ STM.isEmptyTQueue (fchanKey rf) return $! not noKeysPending FrontDiscard -> void $ STM.atomically $ STM.tryReadTQueue (fchanKey rf) FrontAdd kmp -> STM.atomically $ STM.writeTQueue (fchanKey rf) kmp FrontAutoYes b -> writeIORef fautoYesRef b FrontShutdown -> do cancel fasyncTimeout -- In case the last frame display is pending: void $ tryTakeMVar $ fshowNow rf fshutdown rf FrontPrintScreen -> fprintScreen rf display :: RawFrontend -> FrameForall -> IO () display rf@RawFrontend{fshowNow} frontFrame = do let lxsize = fst normalLevelBound + 1 lysize = snd normalLevelBound + 1 canvasLength = lysize + 3 new :: forall s. ST s (G.Mutable U.Vector s Word32) new = do v <- VM.replicate (lxsize * canvasLength) (Color.attrCharW32 Color.spaceAttrW32) unFrameForall frontFrame v return v singleFrame = PointArray.Array lxsize canvasLength (U.create new) putMVar fshowNow () -- 1. wait for permission to display; 3. ack fdisplay rf $ SingleFrame singleFrame defaultMaxFps :: Int defaultMaxFps = 30 microInSec :: Int microInSec = 1000000 -- This thread is canceled forcefully, because the @threadDelay@ -- may be much longer than an acceptable shutdown time. frameTimeoutThread :: Int -> MVar Int -> RawFrontend -> IO () frameTimeoutThread delta fdelay RawFrontend{..} = do let loop = do threadDelay delta let delayLoop = do delay <- readMVar fdelay when (delay > 0) $ do threadDelay $ delta * delay modifyMVar_ fdelay $ return . subtract delay delayLoop delayLoop let showFrameAndRepeatIfKeys = do -- @fshowNow@ is full at this point, unless @saveKM@ emptied it, -- in which case we wait below until @display@ fills it takeMVar fshowNow -- 2. permit display -- @fshowNow@ is ever empty only here, unless @saveKM@ empties it readMVar fshowNow -- 4. wait for ack before starting delay -- @fshowNow@ is full at this point noKeysPending <- STM.atomically $ STM.isEmptyTQueue fchanKey unless noKeysPending $ do void $ swapMVar fdelay 0 -- cancel delays lest they accumulate showFrameAndRepeatIfKeys showFrameAndRepeatIfKeys loop loop -- | The name of the chosen frontend. frontendName :: String frontendName = Chosen.frontendName lazyStartup :: IO RawFrontend lazyStartup = createRawFrontend (\_ -> return ()) (return ()) nullStartup :: IO RawFrontend nullStartup = createRawFrontend seqFrame (return ()) seqFrame :: SingleFrame -> IO () seqFrame SingleFrame{singleFrame} = let seqAttr () attr = Color.colorToRGB (Color.fgFromW32 attr) `seq` Color.bgFromW32 attr `seq` Color.charFromW32 attr == ' ' `seq` () in return $! PointArray.foldlA' seqAttr () singleFrame LambdaHack-0.8.3.0/Game/LambdaHack/Client/UI/HandleHelperM.hs0000644000000000000000000004377113315545734021422 0ustar0000000000000000-- | Helper functions for both inventory management and human commands. module Game.LambdaHack.Client.UI.HandleHelperM ( FailError, showFailError, MError, mergeMError, FailOrCmd, failWith , failSer, failMsg, weaveJust , ppSLore, loreFromMode, loreFromContainer, sortSlots , memberCycle, memberBack, partyAfterLeader, pickLeader, pickLeaderWithPointer , itemOverlay, statsOverlay, pickNumber , lookAtTile, lookAtActors, lookAtItems ) where import Prelude () import Game.LambdaHack.Common.Prelude import qualified Data.Char as Char import qualified Data.EnumMap.Strict as EM import Data.Ord import qualified Data.Text as T import qualified NLP.Miniutter.English as MU import Game.LambdaHack.Client.CommonM import Game.LambdaHack.Client.MonadClient import Game.LambdaHack.Client.State import Game.LambdaHack.Client.UI.ActorUI import Game.LambdaHack.Client.UI.EffectDescription import Game.LambdaHack.Client.UI.ItemDescription import Game.LambdaHack.Client.UI.ItemSlot import qualified Game.LambdaHack.Client.UI.Key as K import Game.LambdaHack.Client.UI.MonadClientUI import Game.LambdaHack.Client.UI.MsgM import Game.LambdaHack.Client.UI.Overlay import Game.LambdaHack.Client.UI.SessionUI import Game.LambdaHack.Client.UI.Slideshow import Game.LambdaHack.Client.UI.SlideshowM import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState import qualified Game.LambdaHack.Common.Color as Color import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.ItemAspect as IA import Game.LambdaHack.Common.Kind import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.MonadStateRead import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.ReqFailure import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Content.ItemKind as IK import qualified Game.LambdaHack.Content.TileKind as TK -- | Message describing the cause of failure of human command. newtype FailError = FailError {failError :: Text} deriving Show showFailError :: FailError -> Text showFailError (FailError err) = "*" <> err <> "*" type MError = Maybe FailError mergeMError :: MError -> MError -> MError mergeMError Nothing Nothing = Nothing mergeMError merr1@Just{} Nothing = merr1 mergeMError Nothing merr2@Just{} = merr2 mergeMError (Just err1) (Just err2) = Just $ FailError $ failError err1 <+> "and" <+> failError err2 type FailOrCmd a = Either FailError a failWith :: MonadClientUI m => Text -> m (FailOrCmd a) failWith err = assert (not $ T.null err) $ return $ Left $ FailError err failSer :: MonadClientUI m => ReqFailure -> m (FailOrCmd a) failSer = failWith . showReqFailure failMsg :: MonadClientUI m => Text -> m MError failMsg err = assert (not $ T.null err) $ return $ Just $ FailError err weaveJust :: FailOrCmd a -> Either MError a weaveJust (Left ferr) = Left $ Just ferr weaveJust (Right a) = Right a ppSLore :: SLore -> Text ppSLore SItem = "item" ppSLore SOrgan = "organ" ppSLore STrunk = "creature" ppSLore STmp = "condition" ppSLore SBlast = "blast" ppSLore SEmbed = "terrain" loreFromMode :: ItemDialogMode -> SLore loreFromMode c = case c of MStore COrgan -> SOrgan MStore _ -> SItem MOrgans -> undefined -- slots from many lore kinds MOwned -> SItem MStats -> undefined -- artificial slots MLore slore -> slore loreFromContainer :: IK.ItemKind -> Container -> SLore loreFromContainer itemKind c = case c of CFloor{} -> SItem CEmbed{} -> SEmbed CActor _ store -> if | IK.isBlast itemKind -> SBlast | IK.isTmpCondition itemKind -> STmp | otherwise -> loreFromMode $ MStore store CTrunk{} -> if IK.isBlast itemKind then SBlast else STrunk sortSlots :: MonadClientUI m => FactionId -> Maybe Actor -> m () sortSlots fid mbody = do itemToF <- getsState $ flip itemToFull s <- getState let sortMap :: SLore -> SingleItemSlots -> SingleItemSlots sortMap slore = let partySet = partyItemSet slore fid mbody s in sortSlotMap itemToF partySet ItemSlots itemSlots <- getsSession sslots let newSlots = ItemSlots $ EM.mapWithKey sortMap itemSlots modifySession $ \sess -> sess {sslots = newSlots} -- | Switches current member to the next on the level, if any, wrapping. memberCycle :: MonadClientUI m => Bool -> m MError memberCycle verbose = do side <- getsClient sside fact <- getsState $ (EM.! side) . sfactionD lidV <- viewedLevelUI leader <- getLeaderUI body <- getsState $ getActorBody leader hs <- partyAfterLeader leader let (autoDun, _) = autoDungeonLevel fact case filter (\(_, b, _) -> blid b == lidV) hs of _ | autoDun && lidV /= blid body -> failMsg $ showReqFailure NoChangeDunLeader [] -> failMsg "cannot pick any other member on this level" (np, b, _) : _ -> do success <- pickLeader verbose np let !_A = assert (success `blame` "same leader" `swith` (leader, np, b)) () return Nothing -- | Switches current member to the previous in the whole dungeon, wrapping. memberBack :: MonadClientUI m => Bool -> m MError memberBack verbose = do side <- getsClient sside fact <- getsState $ (EM.! side) . sfactionD leader <- getLeaderUI hs <- partyAfterLeader leader let (autoDun, _) = autoDungeonLevel fact case reverse hs of _ | autoDun -> failMsg $ showReqFailure NoChangeDunLeader [] -> failMsg "no other member in the party" (np, b, _) : _ -> do success <- pickLeader verbose np let !_A = assert (success `blame` "same leader" `swith` (leader, np, b)) () return Nothing partyAfterLeader :: MonadClientUI m => ActorId -> m [(ActorId, Actor, ActorUI)] partyAfterLeader leader = do side <- getsState $ bfid . getActorBody leader sactorUI <- getsSession sactorUI allA <- getsState $ EM.assocs . sactorD -- not only on one level let allOurs = filter (\(_, body) -> not (bproj body) && bfid body == side) allA allOursUI = map (\(aid, b) -> (aid, b, sactorUI EM.! aid)) allOurs hs = sortBy (comparing keySelected) allOursUI i = fromMaybe (-1) $ findIndex (\(aid, _, _) -> aid == leader) hs (lt, gt) = (take i hs, drop (i + 1) hs) return $! gt ++ lt -- | Select a faction leader. False, if nothing to do. pickLeader :: MonadClientUI m => Bool -> ActorId -> m Bool pickLeader verbose aid = do leader <- getLeaderUI saimMode <- getsSession saimMode if leader == aid then return False -- already picked else do body <- getsState $ getActorBody aid bodyUI <- getsSession $ getActorUI aid let !_A = assert (not (bproj body) `blame` "projectile chosen as the leader" `swith` (aid, body)) () -- Even if it's already the leader, give his proper name, not 'you'. let subject = partActor bodyUI when verbose $ msgAdd $ makeSentence [subject, "picked as a leader"] -- Update client state. s <- getState modifyClient $ updateLeader aid s -- Move the xhair, if active, to the new level. case saimMode of Nothing -> return () Just _ -> modifySession $ \sess -> sess {saimMode = Just $ AimMode $ blid body} -- Inform about items, etc. itemsBlurb <- lookAtItems True (bpos body) aid when verbose $ msgAdd itemsBlurb return True pickLeaderWithPointer :: MonadClientUI m => m MError pickLeaderWithPointer = do lidV <- viewedLevelUI Level{lysize} <- getLevel lidV side <- getsClient sside fact <- getsState $ (EM.! side) . sfactionD arena <- getArenaUI sactorUI <- getsSession sactorUI ours <- getsState $ filter (not . bproj . snd) . actorAssocs (== side) lidV let oursUI = map (\(aid, b) -> (aid, b, sactorUI EM.! aid)) ours viewed = sortBy (comparing keySelected) oursUI (autoDun, _) = autoDungeonLevel fact pick (aid, b) = if | blid b /= arena && autoDun -> failMsg $ showReqFailure NoChangeDunLeader | otherwise -> do void $ pickLeader True aid return Nothing Point{..} <- getsSession spointer -- Pick even if no space in status line for the actor's symbol. if | py == lysize + 2 && px == 0 -> memberBack True | py == lysize + 2 -> case drop (px - 1) viewed of [] -> return Nothing -- relaxed, due to subtleties of display of selected actors (aid, b, _) : _ -> pick (aid, b) | otherwise -> case find (\(_, b, _) -> bpos b == Point px (py - mapStartY)) oursUI of Nothing -> failMsg "not pointing at an actor" Just (aid, b, _) -> pick (aid, b) itemOverlay :: MonadClientUI m => SingleItemSlots -> LevelId -> ItemBag -> m OKX itemOverlay lSlots lid bag = do localTime <- getsState $ getLocalTime lid itemToF <- getsState $ flip itemToFull side <- getsClient sside factionD <- getsState sfactionD combEqp <- getsState $ combinedEqp side combOrgan <- getsState $ combinedOrgan side discoBenefit <- getsClient sdiscoBenefit let !_A = assert (all (`elem` EM.elems lSlots) (EM.keys bag) `blame` (lid, bag, lSlots)) () markEqp iid t = if iid `EM.member` combEqp || iid `EM.member` combOrgan then T.snoc (T.init t) '>' else t pr (l, iid) = case EM.lookup iid bag of Nothing -> Nothing Just kit@(k, _) -> let itemFull = itemToF iid colorSymbol = if IK.isTmpCondition $ itemKind itemFull then let color = if benInEqp (discoBenefit EM.! iid) then Color.BrGreen else Color.BrRed in Color.attrChar2ToW32 color (IK.isymbol $ itemKind itemFull) else viewItem itemFull phrase = makePhrase [snd $ partItemWsRanged side factionD k localTime itemFull kit] al = textToAL (markEqp iid $ slotLabel l) <+:> [colorSymbol] <+:> textToAL phrase kx = (Right l, (undefined, 0, length al)) in Just ([al], kx) (ts, kxs) = unzip $ mapMaybe pr $ EM.assocs lSlots renumber y (km, (_, x1, x2)) = (km, (y, x1, x2)) return (concat ts, zipWith renumber [0..] kxs) statsOverlay :: MonadClient m => ActorId -> m OKX statsOverlay aid = do b <- getsState $ getActorBody aid ar <- getsState $ getActorAspect aid let prSlot :: (Y, SlotChar) -> IA.EqpSlot -> (Text, KYX) prSlot (y, c) eqpSlot = let statName = slotToName eqpSlot fullText t = makePhrase [ MU.Text $ slotLabel c , MU.Text $ T.justifyLeft 22 ' ' statName , MU.Text t ] valueText = slotToDecorator eqpSlot b $ IA.prEqpSlot eqpSlot ar ft = fullText valueText in (ft, (Right c, (y, 0, T.length ft))) (ts, kxs) = unzip $ zipWith prSlot (zip [0..] allSlots) statSlots return (map textToAL ts, kxs) pickNumber :: MonadClientUI m => Bool -> Int -> m (Either MError Int) pickNumber askNumber kAll = assert (kAll >= 1) $ do let shownKeys = [ K.returnKM, K.spaceKM, K.mkChar '+', K.mkChar '-' , K.backspaceKM, K.escKM ] frontKeyKeys = shownKeys ++ map K.mkChar ['0'..'9'] gatherNumber kCur = assert (1 <= kCur && kCur <= kAll) $ do let kprompt = "Choose number:" <+> tshow kCur promptAdd0 kprompt sli <- reportToSlideshow shownKeys ekkm <- displayChoiceScreen "" ColorFull False sli frontKeyKeys case ekkm of Left kkm -> case K.key kkm of K.Char '+' -> gatherNumber $ if kCur + 1 > kAll then 1 else kCur + 1 K.Char '-' -> gatherNumber $ if kCur - 1 < 1 then kAll else kCur - 1 K.Char l | kCur * 10 + Char.digitToInt l > kAll -> gatherNumber $ if Char.digitToInt l == 0 then kAll else min kAll (Char.digitToInt l) K.Char l -> gatherNumber $ kCur * 10 + Char.digitToInt l K.BackSpace -> gatherNumber $ max 1 (kCur `div` 10) K.Return -> return $ Right kCur K.Esc -> weaveJust <$> failWith "never mind" K.Space -> return $ Left Nothing _ -> error $ "unexpected key" `showFailure` kkm Right sc -> error $ "unexpected slot char" `showFailure` sc if | kAll == 1 || not askNumber -> return $ Right kAll | otherwise -> do res <- gatherNumber kAll case res of Right k | k <= 0 -> error $ "" `showFailure` (res, kAll) _ -> return res -- | Produces a textual description of the tile at a position. lookAtTile :: MonadClientUI m => Bool -- ^ can be seen right now? -> Point -- ^ position to describe -> ActorId -- ^ the actor that looks -> LevelId -- ^ level the position is at -> m Text lookAtTile canSee p aid lidV = do COps{cotile} <- getsState scops side <- getsClient sside factionD <- getsState sfactionD b <- getsState $ getActorBody aid lvl <- getLevel lidV embeds <- getsState $ getEmbedBag lidV p itemToF <- getsState $ flip itemToFull seps <- getsClient seps mnewEps <- makeLine False b p seps localTime <- getsState $ getLocalTime lidV let aims = isJust mnewEps tile = lvl `at` p vis | TK.isUknownSpace tile = "that is" | not canSee = "you remember" | not aims = "you are aware of" | otherwise = "you see" tilePart = MU.AW $ MU.Text $ TK.tname $ okind cotile tile itemLook (iid, kit@(k, _)) = let itemFull = itemToF iid (temporary, nWs) = partItemWs side factionD k localTime itemFull kit verb = if k == 1 || temporary then "is" else "are" ik = itemKind itemFull desc = IK.idesc ik in makeSentence ["There", verb, nWs] <+> desc ilooks = T.intercalate " " $ map itemLook $ EM.assocs embeds return $! makeSentence [MU.Text vis, tilePart] <+> ilooks -- | Produces a textual description of actors at a position. lookAtActors :: MonadClientUI m => Point -- ^ position to describe -> LevelId -- ^ level the position is at -> m Text lookAtActors p lidV = do side <- getsClient sside inhabitants <- getsState $ posToAssocs p lidV sactorUI <- getsSession sactorUI let inhabitantsUI = map (\(aid2, b2) -> (aid2, b2, sactorUI EM.! aid2)) inhabitants itemToF <- getsState $ flip itemToFull factionD <- getsState sfactionD let actorsBlurb = case inhabitants of [] -> "" (_, body) : rest -> let itemFull = itemToF (btrunk body) bfact = factionD EM.! bfid body -- Even if it's the leader, give his proper name, not 'you'. subjects = map (\(_, _, bUI) -> partActor bUI) inhabitantsUI -- No "a" prefix even if singular and inanimate, to distinguish -- from items lying on the floor (and to simplify code). (subject, person) = squashedWWandW subjects verb = "be here" factDesc = case jfid $ itemBase itemFull of Just tfid | tfid /= bfid body -> let dominatedBy = if bfid body == side then "us" else gname bfact tfact = factionD EM.! tfid in "Originally of" <+> gname tfact <> ", now fighting for" <+> dominatedBy <> "." _ | bfid body == side -> "" -- just one of us _ | bproj body -> "Launched by" <+> gname bfact <> "." _ -> "One of" <+> gname bfact <> "." idesc = IK.idesc $ itemKind itemFull -- If many different actors (projectiles), only list names. sameTrunks = all (\(_, b) -> btrunk b == btrunk body) rest desc = if sameTrunks then factDesc <+> idesc else "" -- Both description and faction blurb may be empty. pdesc = if desc == "" then "" else "(" <> desc <> ")" in makeSentence [MU.SubjectVerb person MU.Yes subject verb] <+> pdesc return $! actorsBlurb -- | Produces a textual description of items at a position. lookAtItems :: MonadClientUI m => Bool -- ^ can be seen right now? -> Point -- ^ position to describe -> ActorId -- ^ the actor that looks -> m Text lookAtItems canSee p aid = do itemToF <- getsState $ flip itemToFull b <- getsState $ getActorBody aid -- Not using @viewedLevelUI@, because @aid@ may be temporarily not a leader. saimMode <- getsSession saimMode let lidV = maybe (blid b) aimLevelId saimMode localTime <- getsState $ getLocalTime lidV subject <- partAidLeader aid is <- getsState $ getFloorBag lidV p side <- getsClient sside factionD <- getsState sfactionD let verb = MU.Text $ if | p == bpos b && lidV == blid b -> "stand on" | canSee -> "notice" | otherwise -> "remember" nWs (iid, kit@(k, _)) = partItemWs side factionD k localTime (itemToF iid) kit -- Here @squashedWWandW@ is not needed, because identical items at the same -- position are already merged in the floor item bag and multiple identical -- messages concerning different positions are merged with -- to distinguish from a stack of items at a single position. return $! if EM.null is then "" else makeSentence [ MU.SubjectVerbSg subject verb , MU.WWandW $ map (snd . nWs) $ EM.assocs is] LambdaHack-0.8.3.0/Game/LambdaHack/Client/UI/Content/0000755000000000000000000000000013315545734020014 5ustar0000000000000000LambdaHack-0.8.3.0/Game/LambdaHack/Client/UI/Content/KeyKind.hs0000644000000000000000000001345313315545734021714 0ustar0000000000000000-- | The type of definitions of key-command mappings to be used for the UI -- and shorthands for specifying command triples in the content files. module Game.LambdaHack.Client.UI.Content.KeyKind ( KeyKind(..), evalKeyDef , addCmdCategory, replaceDesc, moveItemTriple, repeatTriple , mouseLMB, mouseMMB, mouseRMB , goToCmd, runToAllCmd, autoexploreCmd, autoexplore25Cmd , aimFlingCmd, projectI, projectA, flingTs, applyIK, applyI , grabItems, dropItems, descIs, descTs, defaultHeroSelect #ifdef EXPOSE_INTERNAL -- * Internal operations , replaceCmd, projectICmd, grabCmd, dropCmd #endif ) where import Prelude () import Game.LambdaHack.Common.Prelude import qualified Data.Char as Char import qualified NLP.Miniutter.English as MU import Game.LambdaHack.Client.UI.ActorUI (verbCStore) import Game.LambdaHack.Client.UI.HumanCmd import qualified Game.LambdaHack.Client.UI.Key as K import Game.LambdaHack.Common.Misc -- | Key-command mappings to be specified in content and used for the UI. newtype KeyKind = KeyKind [(K.KM, CmdTriple)] -- ^ default client UI commands evalKeyDef :: (String, CmdTriple) -> (K.KM, CmdTriple) evalKeyDef (t, triple@(cats, _, _)) = let km = if CmdInternal `elem` cats then K.KM K.NoModifier $ K.Unknown t else K.mkKM t in (km, triple) addCmdCategory :: CmdCategory -> CmdTriple -> CmdTriple addCmdCategory cat (cats, desc, cmd) = (cat : cats, desc, cmd) replaceDesc :: Text -> CmdTriple -> CmdTriple replaceDesc desc (cats, _, cmd) = (cats, desc, cmd) replaceCmd :: HumanCmd -> CmdTriple -> CmdTriple replaceCmd cmd (cats, desc, _) = (cats, desc, cmd) moveItemTriple :: [CStore] -> CStore -> MU.Part -> Bool -> CmdTriple moveItemTriple stores1 store2 object auto = let verb = MU.Text $ verbCStore store2 desc = makePhrase [verb, object] in ([CmdItemMenu], desc, MoveItem stores1 store2 Nothing auto) repeatTriple :: Int -> CmdTriple repeatTriple n = ( [CmdMeta] , "voice recorded commands" <+> tshow n <+> "times" , Repeat n ) -- @AimFloor@ is not there, but @AimEnemy@ and @AimItem@ almost make up for it. mouseLMB :: CmdTriple mouseLMB = ( [CmdMouse] , "set x-hair to enemy/go to pointer for 25 steps" , ByAimMode { exploration = ByArea $ common ++ -- exploration mode [ (CaMapLeader, grabCmd) , (CaMapParty, PickLeaderWithPointer) , (CaMap, goToCmd) , (CaArenaName, Dashboard) , (CaPercentSeen, autoexploreCmd) ] , aiming = ByArea $ common ++ -- aiming mode [ (CaMap, AimPointerEnemy) , (CaArenaName, Accept) , (CaPercentSeen, XhairStair True) ] } ) where common = [ (CaMessage, ExecuteIfClear History) , (CaLevelNumber, AimAscend 1) , (CaXhairDesc, AimEnemy) -- inits aiming and then cycles enemies , (CaSelected, PickLeaderWithPointer) , (CaCalmGauge, Macro ["KP_5", "C-V"]) , (CaHPGauge, Wait) , (CaTargetDesc, projectICmd flingTs) ] mouseMMB :: CmdTriple mouseMMB = ( [CmdMouse] , "snap x-hair to floor under pointer" , XhairPointerFloor ) mouseRMB :: CmdTriple mouseRMB = ( [CmdMouse] , "fling at enemy/run to pointer collectively for 25 steps" , ByAimMode { exploration = ByArea $ common ++ [ (CaMapLeader, dropCmd) , (CaMapParty, SelectWithPointer) , (CaMap, runToAllCmd) , (CaArenaName, MainMenu) , (CaPercentSeen, autoexplore25Cmd) ] , aiming = ByArea $ common ++ [ (CaMap, aimFlingCmd) , (CaArenaName, Cancel) , (CaPercentSeen, XhairStair False) ] } ) where common = [ (CaMessage, Hint) , (CaLevelNumber, AimAscend (-1)) , (CaXhairDesc, AimItem) , (CaSelected, SelectWithPointer) , (CaCalmGauge, Macro ["C-KP_5", "V"]) , (CaHPGauge, Wait10) , (CaTargetDesc, ComposeUnlessError ItemClear TgtClear) ] goToCmd :: HumanCmd goToCmd = Macro ["MiddleButtonRelease", "C-semicolon", "C-/", "C-V"] runToAllCmd :: HumanCmd runToAllCmd = Macro ["MiddleButtonRelease", "C-colon", "C-/", "C-V"] autoexploreCmd :: HumanCmd autoexploreCmd = Macro ["C-?", "C-/", "C-V"] autoexplore25Cmd :: HumanCmd autoexplore25Cmd = Macro ["'", "C-?", "C-/", "'", "C-V"] aimFlingCmd :: HumanCmd aimFlingCmd = ComposeIfLocal AimPointerEnemy (projectICmd flingTs) projectICmd :: [TriggerItem] -> HumanCmd projectICmd ts = ComposeUnlessError (ChooseItemProject ts) Project projectI :: [TriggerItem] -> CmdTriple projectI ts = ([], descIs ts, projectICmd ts) projectA :: [TriggerItem] -> CmdTriple projectA ts = replaceCmd ByAimMode { exploration = AimTgt , aiming = projectICmd ts } (projectI ts) flingTs :: [TriggerItem] flingTs = [TriggerItem { tiverb = "fling" , tiobject = "projectile" , tisymbols = "" }] applyIK :: [TriggerItem] -> CmdTriple applyIK ts = ([], descIs ts, ComposeUnlessError (ChooseItemApply ts) Apply) applyI :: [TriggerItem] -> CmdTriple applyI ts = let apply = Compose2ndLocal Apply ItemClear in ([], descIs ts, ComposeUnlessError (ChooseItemApply ts) apply) grabCmd :: HumanCmd grabCmd = MoveItem [CGround] CEqp (Just "grab") True -- @CEqp@ is the implicit default; refined in HandleHumanGlobalM grabItems :: Text -> CmdTriple grabItems t = ([CmdItemMenu], t, grabCmd) dropCmd :: HumanCmd dropCmd = MoveItem [CEqp, CInv, CSha] CGround Nothing False dropItems :: Text -> CmdTriple dropItems t = ([CmdItemMenu], t, dropCmd) descIs :: [TriggerItem] -> Text descIs [] = "trigger an item" descIs (t : _) = makePhrase [tiverb t, tiobject t] descTs :: [TriggerTile] -> Text descTs [] = "alter a tile" descTs (t : _) = makePhrase [ttverb t, ttobject t] defaultHeroSelect :: Int -> (String, CmdTriple) defaultHeroSelect k = ([Char.intToDigit k], ([CmdMeta], "", PickLeader k)) LambdaHack-0.8.3.0/Game/LambdaHack/Client/UI/Frontend/0000755000000000000000000000000013315545734020161 5ustar0000000000000000LambdaHack-0.8.3.0/Game/LambdaHack/Client/UI/Frontend/Common.hs0000644000000000000000000000611113315545734021744 0ustar0000000000000000-- | Screen frames and animations. module Game.LambdaHack.Client.UI.Frontend.Common ( RawFrontend(..) , startupBound, createRawFrontend, resetChanKey, saveKMP , modifierTranslate ) where import Prelude () import Game.LambdaHack.Common.Prelude import Control.Concurrent import qualified Control.Concurrent.STM as STM import Game.LambdaHack.Client.UI.Frame import Game.LambdaHack.Client.UI.Key (KMP (..)) import qualified Game.LambdaHack.Client.UI.Key as K import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.Point -- | Raw frontend definition. The minimal closed set of values that need -- to depend on the specifics of the chosen frontend. data RawFrontend = RawFrontend { fdisplay :: SingleFrame -> IO () , fshutdown :: IO () , fshowNow :: MVar () , fchanKey :: STM.TQueue KMP , fprintScreen :: IO () } -- | Start up a frontend on a bound thread. -- -- In fact, it is started on the very main thread, via a hack, because -- apparently some SDL backends are not thread-safe -- (; -- "this should only be run in the thread that initialized the video subsystem, -- and for extra safety, you should consider only doing those things -- on the main thread in any case") -- and at least the newer OS X obtusely requires the main thread, see -- https://github.com/AllureOfTheStars/Allure/issues/79 -- In case any other exotic architecture requires the main thread, -- we make the hack the default for all (on frontends that require a bound -- thread, e.g., SLD2 or GTK). startupBound :: (MVar RawFrontend -> IO ()) -> IO RawFrontend startupBound k = do rfMVar <- newEmptyMVar putMVar workaroundOnMainThreadMVar $ k rfMVar -- The following would run frontend on a bound thread, but it's not enough: -- a <- asyncBound $ k rfMVar -- link a takeMVar rfMVar createRawFrontend :: (SingleFrame -> IO ()) -> IO () -> IO RawFrontend createRawFrontend fdisplay fshutdown = do -- Set up the channel for keyboard input. fchanKey <- STM.atomically STM.newTQueue -- Create the session record. fshowNow <- newEmptyMVar return $! RawFrontend { fdisplay , fshutdown , fshowNow , fchanKey , fprintScreen = return () -- dummy, except fro SDL2 } -- | Empty the keyboard channel. resetChanKey :: STM.TQueue KMP -> IO () resetChanKey fchanKey = do res <- STM.atomically $ STM.tryReadTQueue fchanKey when (isJust res) $ resetChanKey fchanKey saveKMP :: RawFrontend -> K.Modifier -> K.Key -> Point -> IO () saveKMP !rf !modifier !key !kmpPointer = do -- Instantly show any frame waiting for display. void $ tryTakeMVar $ fshowNow rf let kmp = KMP{kmpKeyMod = K.KM{..}, kmpPointer} unless (key == K.DeadKey) $ -- Store the key in the channel. STM.atomically $ STM.writeTQueue (fchanKey rf) kmp -- | Translates modifiers to our own encoding. modifierTranslate :: Bool -> Bool -> Bool -> Bool -> K.Modifier modifierTranslate modCtrl modShift modAlt modMeta | modCtrl = K.Control | modAlt || modMeta = K.Alt | modShift = K.Shift | otherwise = K.NoModifier LambdaHack-0.8.3.0/Game/LambdaHack/Client/UI/Frontend/Gtk.hs0000644000000000000000000002316213315545734021246 0ustar0000000000000000{-# OPTIONS_GHC -Wno-unused-do-bind #-} -- | Text frontend based on Gtk. module Game.LambdaHack.Client.UI.Frontend.Gtk ( startup, frontendName ) where import Prelude () import Game.LambdaHack.Common.Prelude hiding (Alt) import Control.Concurrent import qualified Control.Monad.IO.Class as IO import qualified Data.IntMap.Strict as IM import Data.IORef import qualified Data.Text as T import qualified Game.LambdaHack.Common.PointArray as PointArray import Graphics.UI.Gtk hiding (Point) import System.Exit (exitFailure) import Game.LambdaHack.Client.ClientOptions import Game.LambdaHack.Client.UI.Frame import Game.LambdaHack.Client.UI.Frontend.Common import qualified Game.LambdaHack.Client.UI.Key as K import qualified Game.LambdaHack.Common.Color as Color import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.Point -- | Session data maintained by the frontend. data FrontendSession = FrontendSession { sview :: TextView -- ^ the widget to draw to , stags :: IM.IntMap TextTag -- ^ text color tags for fg/bg } -- | The name of the frontend. frontendName :: String frontendName = "gtk" -- | Set up and start the main GTK loop providing input and output. -- -- Because of Windows, GTK needs to be on a bound thread, -- so we can't avoid the communication overhead of bound threads. startup :: ClientOptions -> IO RawFrontend startup soptions = startupBound $ startupFun soptions startupFun :: ClientOptions -> MVar RawFrontend -> IO () startupFun soptions@ClientOptions{..} rfMVar = do -- Init GUI. unsafeInitGUIForThreadedRTS -- Text attributes. let emulateBox attr = case attr of Color.Attr{bg=Color.HighlightNone,fg} -> (fg, Color.Black) Color.Attr{bg=Color.HighlightRed} -> (Color.Black, Color.defFG) Color.Attr{bg=Color.HighlightBlue,fg} -> if fg /= Color.Blue then (fg, Color.Blue) else (fg, Color.BrBlack) Color.Attr{bg=Color.HighlightYellow,fg} -> if fg /= Color.Brown then (fg, Color.Brown) else (fg, Color.defFG) Color.Attr{bg=Color.HighlightGrey,fg} -> if fg /= Color.BrBlack then (fg, Color.BrBlack) else (fg, Color.defFG) Color.Attr{fg} -> (fg, Color.Black) ttt <- textTagTableNew stags <- IM.fromDistinctAscList <$> mapM (\ak -> do tt <- textTagNew Nothing textTagTableAdd ttt tt doAttr soptions tt (emulateBox ak) return (fromEnum ak, tt)) [ Color.Attr{fg, bg} | fg <- [minBound..maxBound], bg <- [minBound..maxBound] ] -- Text buffer. tb <- textBufferNew (Just ttt) -- Create text view. sview <- textViewNewWithBuffer tb textViewSetEditable sview False textViewSetCursorVisible sview False widgetDelEvents sview [SmoothScrollMask, TouchMask] widgetAddEvents sview [ScrollMask] let sess = FrontendSession{..} rf <- createRawFrontend (display sess) shutdown putMVar rfMVar rf let modTranslate mods = modifierTranslate (Control `elem` mods) (Shift `elem` mods) (any (`elem` mods) [Alt, Alt2, Alt3, Alt4, Alt5]) (any (`elem` mods) [Meta, Super]) sview `on` keyPressEvent $ do n <- eventKeyName mods <- eventModifier let key = K.keyTranslate $ T.unpack n modifier = let md = modTranslate mods in if md == K.Shift then K.NoModifier else md pointer = originPoint when (key == K.Esc) $ IO.liftIO $ resetChanKey (fchanKey rf) IO.liftIO $ saveKMP rf modifier key pointer return True -- Set the font specified in config, if any. f <- fontDescriptionFromString $ fromMaybe "Monospace" sgtkFontFamily <+> maybe "16" tshow sfontSize <> "px" widgetModifyFont sview (Just f) IO.liftIO $ do textViewSetLeftMargin sview 3 textViewSetRightMargin sview 3 -- Take care of the mouse events. sview `on` scrollEvent $ do IO.liftIO $ resetChanKey (fchanKey rf) scrollDir <- eventScrollDirection (wx, wy) <- eventCoordinates mods <- eventModifier let modifier = modTranslate mods -- Shift included IO.liftIO $ do (bx, by) <- textViewWindowToBufferCoords sview TextWindowText (round wx, round wy) (iter, _) <- textViewGetIterAtPosition sview bx by cx <- textIterGetLineOffset iter cy <- textIterGetLine iter let pointer = Point cx cy -- Store the mouse event coords in the keypress channel. storeK key = saveKMP rf modifier key pointer case scrollDir of ScrollUp -> storeK K.WheelNorth ScrollDown -> storeK K.WheelSouth _ -> return () -- ignore any fancy new gizmos return True -- disable selection currentfont <- newIORef f Just defDisplay <- displayGetDefault cursor <- cursorNewForDisplay defDisplay Tcross -- Target Crosshair Arrow sview `on` buttonPressEvent $ return True -- disable selection sview `on` buttonReleaseEvent $ do IO.liftIO $ resetChanKey (fchanKey rf) but <- eventButton (wx, wy) <- eventCoordinates mods <- eventModifier let modifier = modTranslate mods -- Shift included IO.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 mdrawWin <- displayGetWindowAtPointer defDisplay 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 mkey = case but of LeftButton -> Just K.LeftButtonRelease MiddleButton -> Just K.MiddleButtonRelease RightButton -> Just K.RightButtonRelease _ -> Nothing -- probably a glitch pointer = Point cx cy -- Store the mouse event coords in the keypress channel. maybe (return ()) (\key -> IO.liftIO $ saveKMP rf modifier key pointer) mkey return True -- Modify default colours. let black = Color minBound minBound minBound -- Color.defBG == Color.Black white = Color 0xC500 0xBC00 0xB800 -- Color.defFG == Color.White widgetModifyBg sview StateNormal black widgetModifyFg sview StateNormal white -- Set up the main window. w <- windowNew containerAdd w sview -- We assume it's intentional window kill by the player, -- so game is not saved, unlike with assertion failure, etc. w `on` deleteEvent $ IO.liftIO $ do putStrLn "Window killed" mainQuit exitFailure widgetShowAll w mainGUI shutdown :: IO () shutdown = postGUISync mainQuit doAttr :: ClientOptions -> TextTag -> (Color.Color, Color.Color) -> IO () doAttr soptions tt (fg, bg) | fg == Color.defFG && bg == Color.Black = return () | fg == Color.defFG = set tt [textTagBackground := Color.colorToRGB bg] | bg == Color.Black = set tt $ extraAttr soptions ++ [textTagForeground := Color.colorToRGB fg] | otherwise = set tt $ extraAttr soptions ++ [ textTagForeground := Color.colorToRGB fg , textTagBackground := Color.colorToRGB bg ] extraAttr :: ClientOptions -> [AttrOp TextTag] extraAttr ClientOptions{scolorIsBold} = [textTagWeight := fromEnum WeightBold | scolorIsBold == Just True] -- , textTagStretch := StretchUltraExpanded -- | Add a frame to be drawn. display :: FrontendSession -- ^ frontend session data -> SingleFrame -- ^ the screen frame to draw -> IO () display FrontendSession{..} SingleFrame{singleFrame} = do let lxsize1 = fst normalLevelBound + 2 f !w (!n, !l) = if n == -1 then (lxsize1 - 3, Color.charFromW32 w : '\n' : l) else (n - 1, Color.charFromW32 w : l) (_, levelChar) = PointArray.foldrA' f (lxsize1 - 2, []) singleFrame !gfChar = T.pack levelChar postGUISync $ do tb <- textViewGetBuffer sview textBufferSetText tb gfChar ib <- textBufferGetStartIter tb ie <- textIterCopy ib let defEnum = fromEnum Color.defAttr setTo :: (X, Int) -> Color.AttrCharW32 -> IO (X, Int) setTo (!lx, !previous) !w | (lx + 1) `mod` lxsize1 /= 0 = do let current :: Int current = Color.attrEnumFromW32 w if current == previous then return (lx + 1, previous) else do textIterSetOffset ie lx when (previous /= defEnum) $ textBufferApplyTag tb (stags IM.! previous) ib ie textIterSetOffset ib lx return (lx + 1, current) setTo (lx, previous) w = setTo (lx + 1, previous) w (lx, previous) <- PointArray.foldMA' setTo (-1, defEnum) singleFrame textIterSetOffset ie lx when (previous /= defEnum) $ textBufferApplyTag tb (stags IM.! previous) ib ie LambdaHack-0.8.3.0/Game/LambdaHack/Client/UI/Frontend/Teletype.hs0000644000000000000000000000551613315545734022317 0ustar0000000000000000-- | Line terminal text frontend based on stdin/stdout, intended for logging -- tests, but may be used on a teletype terminal, or with keyboard and printer. module Game.LambdaHack.Client.UI.Frontend.Teletype ( startup, frontendName ) where import Prelude () import Game.LambdaHack.Common.Prelude import Control.Concurrent.Async import Data.Char (chr, ord) import qualified Data.Char as Char import qualified System.IO as SIO import Game.LambdaHack.Client.ClientOptions import Game.LambdaHack.Client.UI.Frame import Game.LambdaHack.Client.UI.Frontend.Common import qualified Game.LambdaHack.Client.UI.Key as K import qualified Game.LambdaHack.Common.Color as Color import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.Point import qualified Game.LambdaHack.Common.PointArray as PointArray -- No session data maintained by this frontend -- | The name of the frontend. frontendName :: String frontendName = "teletype" -- | Set up the frontend input and output. startup :: ClientOptions -> IO RawFrontend startup _soptions = do rf <- createRawFrontend display shutdown let storeKeys :: IO () storeKeys = do l <- SIO.getLine -- blocks here, so no polling let c = case l of [] -> '\n' -- empty line counts as RET hd : _ -> hd K.KM{..} = keyTranslate c saveKMP rf modifier key originPoint storeKeys void $ async storeKeys return $! rf shutdown :: IO () shutdown = SIO.hFlush SIO.stdout >> SIO.hFlush SIO.stderr -- | Output to the screen via the frontend. display :: SingleFrame -- ^ the screen frame to draw -> IO () display SingleFrame{singleFrame} = let f w l = let acCharRaw = Color.charFromW32 w acChar = if Char.ord acCharRaw == 183 then '.' else acCharRaw in acChar : l levelChar = chunk $ PointArray.foldrA f [] singleFrame lxsize = fst normalLevelBound + 1 chunk [] = [] chunk l = let (ch, r) = splitAt lxsize l in ch : chunk r in SIO.hPutStrLn SIO.stderr $ unlines levelChar keyTranslate :: Char -> K.KM keyTranslate e = (\(key, modifier) -> K.KM modifier key) $ case e of '\ESC' -> (K.Esc, K.NoModifier) '\n' -> (K.Return, K.NoModifier) '\r' -> (K.Return, K.NoModifier) ' ' -> (K.Space, K.NoModifier) '\t' -> (K.Tab, K.NoModifier) c | ord '\^A' <= ord c && ord c <= ord '\^Z' -> -- Alas, only lower-case letters. (K.Char $ chr $ ord c - ord '\^A' + ord 'a', K.Control) -- Movement keys are more important than leader picking, -- so disabling the latter and interpreting the keypad numbers -- as movement: | c `elem` ['1'..'9'] -> (K.KP c, K.NoModifier) | otherwise -> (K.Char c, K.NoModifier) LambdaHack-0.8.3.0/Game/LambdaHack/Client/UI/Frontend/Curses.hs0000644000000000000000000001610013315545734021757 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 ( startup, frontendName ) where import Prelude () import Game.LambdaHack.Common.Prelude import Control.Concurrent.Async 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 Game.LambdaHack.Client.ClientOptions import Game.LambdaHack.Client.UI.Frame import Game.LambdaHack.Client.UI.Frontend.Common import qualified Game.LambdaHack.Client.UI.Key as K import qualified Game.LambdaHack.Common.Color as Color import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.Point import qualified Game.LambdaHack.Common.PointArray as PointArray -- | Session data maintained by the frontend. data FrontendSession = FrontendSession { swin :: C.Window -- ^ the window to draw to , sstyles :: M.Map (Color.Color, Color.Color) C.CursesStyle -- ^ map from fore/back colour pairs to defined curses styles } -- | The name of the frontend. frontendName :: String frontendName = "curses" -- | Starts the main program loop using the frontend input and output. startup :: ClientOptions -> IO RawFrontend startup _soptions = do C.start void $ C.cursSet C.CursorInvisible let s = [ ((fg, bg), C.Style (toFColor fg) (toBColor bg)) | -- No more color combinations possible: 16*4, 64 is max. fg <- [minBound..maxBound] , bg <- [Color.Black, Color.Blue, Color.White, Color.BrBlack] ] nr <- C.colorPairs when (nr < length s) $ C.end >> error ("terminal has too few color pairs" `showFailure` nr) let (ks, vs) = unzip s ws <- C.convertStyles vs let swin = C.stdScr sstyles = M.fromDistinctAscList (zip ks ws) sess = FrontendSession{..} rf <- createRawFrontend (display sess) shutdown let storeKeys :: IO () storeKeys = do K.KM{..} <- keyTranslate <$> C.getKey C.refresh saveKMP rf modifier key originPoint storeKeys void $ async storeKeys return $! rf shutdown :: IO () shutdown = C.end -- | Output to the screen via the frontend. display :: FrontendSession -- ^ frontend session data -> SingleFrame -- ^ the screen frame to draw -> IO () display FrontendSession{..} SingleFrame{singleFrame} = do -- let defaultStyle = C.defaultCursesStyle -- Terminals with white background require this: let defaultStyle = sstyles M.! (Color.defFG, Color.Black) 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 sf = chunk $ map Color.attrCharFromW32 $ PointArray.toListA singleFrame level = init sf ++ [init $ last sf] nm = zip [0..] $ map (zip [0..]) level lxsize = fst normalLevelBound + 1 chunk [] = [] chunk l = let (ch, r) = splitAt lxsize l in ch : chunk r sequence_ [ C.setStyle (M.findWithDefault defaultStyle acAttr2 sstyles) >> C.mvWAddStr swin y x [acChar] | (y, line) <- nm , (x, Color.AttrChar{acAttr=Color.Attr{..}, ..}) <- line , let acAttr2 = case bg of Color.HighlightNone -> (fg, Color.Black) Color.HighlightRed -> (Color.Black, Color.defFG) Color.HighlightBlue -> if fg /= Color.Blue then (fg, Color.Blue) else (fg, Color.BrBlack) Color.HighlightYellow -> if fg /= Color.Brown then (fg, Color.Brown) else (fg, Color.defFG) Color.HighlightGrey -> if fg /= Color.BrBlack then (fg, Color.BrBlack) else (fg, Color.defFG) _ -> (fg, Color.Black) ] C.refresh keyTranslate :: C.Key -> K.KM keyTranslate e = (\(key, modifier) -> K.KM 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 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 (show e), K.NoModifier) toFColor :: Color.Color -> C.ForegroundColor toFColor Color.Black = C.BlackF toFColor Color.Red = C.DarkRedF toFColor Color.Green = C.DarkGreenF toFColor Color.Brown = C.BrownF toFColor Color.Blue = C.DarkBlueF toFColor Color.Magenta = C.PurpleF toFColor Color.Cyan = C.DarkCyanF toFColor Color.White = C.WhiteF toFColor Color.BrBlack = C.GreyF toFColor Color.BrRed = C.RedF toFColor Color.BrGreen = C.GreenF toFColor Color.BrYellow = C.YellowF toFColor Color.BrBlue = C.BlueF toFColor Color.BrMagenta = C.MagentaF toFColor Color.BrCyan = C.CyanF toFColor Color.BrWhite = C.BrightWhiteF toBColor :: Color.Color -> C.BackgroundColor toBColor Color.Black = C.BlackB toBColor Color.Red = C.DarkRedB toBColor Color.Green = C.DarkGreenB toBColor Color.Brown = C.BrownB toBColor Color.Blue = C.DarkBlueB toBColor Color.Magenta = C.PurpleB toBColor Color.Cyan = C.DarkCyanB toBColor Color.White = C.WhiteB toBColor _ = C.BlackB -- a limitation of curses LambdaHack-0.8.3.0/Game/LambdaHack/Client/UI/Frontend/Vty.hs0000644000000000000000000001143313315545734021301 0ustar0000000000000000-- | Text frontend based on Vty. module Game.LambdaHack.Client.UI.Frontend.Vty ( startup, frontendName ) where import Prelude () import Game.LambdaHack.Common.Prelude import Control.Concurrent.Async import Graphics.Vty import qualified Graphics.Vty as Vty import Game.LambdaHack.Client.UI.Frame import Game.LambdaHack.Client.UI.Frontend.Common import qualified Game.LambdaHack.Client.UI.Key as K import Game.LambdaHack.Client.ClientOptions import qualified Game.LambdaHack.Common.Color as Color import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.Point import qualified Game.LambdaHack.Common.PointArray as PointArray -- | Session data maintained by the frontend. newtype FrontendSession = FrontendSession { svty :: Vty -- ^ internal vty session } -- | The name of the frontend. frontendName :: String frontendName = "vty" -- | Starts the main program loop using the frontend input and output. startup :: ClientOptions -> IO RawFrontend startup _soptions = do svty <- mkVty mempty let sess = FrontendSession{..} rf <- createRawFrontend (display sess) (Vty.shutdown svty) let storeKeys :: IO () storeKeys = do e <- nextEvent svty -- blocks here, so no polling case e of EvKey n mods -> saveKMP rf (modTranslate mods) (keyTranslate n) originPoint _ -> return () storeKeys void $ async storeKeys return $! rf -- | Output to the screen via the frontend. display :: FrontendSession -- ^ frontend session data -> SingleFrame -- ^ the screen frame to draw -> IO () display FrontendSession{svty} SingleFrame{singleFrame} = let img = foldr (<->) emptyImage . map (foldr (<|>) emptyImage . map (\w -> char (setAttr $ Color.attrFromW32 w) (Color.charFromW32 w))) $ chunk $ PointArray.toListA singleFrame pic = picForImage img lxsize = fst normalLevelBound + 1 chunk [] = [] chunk l = let (ch, r) = splitAt lxsize l in ch : chunk r in update svty pic 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 -- C-Home and C-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 (show n) -- | Translates modifiers to our own encoding. modTranslate :: [Modifier] -> K.Modifier modTranslate mods = modifierTranslate (MCtrl `elem` mods) (MShift `elem` mods) (MAlt `elem` mods) False -- 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{..} = -- This optimization breaks display for white background terminals: -- if (fg, bg) == Color.defAttr -- then def_attr -- else let (fg1, bg1) = case bg of Color.HighlightNone -> (fg, Color.Black) Color.HighlightRed -> (Color.Black, Color.defFG) Color.HighlightBlue -> if fg /= Color.Blue then (fg, Color.Blue) else (fg, Color.BrBlack) Color.HighlightYellow -> if fg /= Color.Brown then (fg, Color.Brown) else (fg, Color.defFG) Color.HighlightGrey -> if fg /= Color.BrBlack then (fg, Color.BrBlack) else (fg, Color.defFG) _ -> (fg, Color.Black) in hack fg1 $ hack bg1 $ defAttr { attrForeColor = SetTo (aToc fg1) , attrBackColor = SetTo (aToc bg1) } 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.8.3.0/Game/LambdaHack/Client/UI/Frontend/Dom.hs0000644000000000000000000002726513315545734021250 0ustar0000000000000000-- | Text frontend running in a browser. module Game.LambdaHack.Client.UI.Frontend.Dom ( startup, frontendName ) where import Prelude () import Game.LambdaHack.Common.Prelude import Control.Concurrent import qualified Control.Monad.IO.Class as IO import Control.Monad.Trans.Reader (ask) import qualified Data.Char as Char import Data.IORef import qualified Data.Vector as V import qualified Data.Vector.Unboxed as U import Data.Word (Word32) import GHCJS.DOM (currentDocument, currentWindow) import GHCJS.DOM.CSSStyleDeclaration (setProperty) import GHCJS.DOM.Document (createElement, getBodyUnchecked) import GHCJS.DOM.Element (Element (Element), setInnerHTML) import GHCJS.DOM.ElementCSSInlineStyle (getStyle) import GHCJS.DOM.EventM (EventM, mouseAltKey, mouseButton, mouseCtrlKey, mouseMetaKey, mouseShiftKey, on, preventDefault, stopPropagation) import GHCJS.DOM.GlobalEventHandlers (contextMenu, keyDown, mouseUp, wheel) import GHCJS.DOM.HTMLCollection (itemUnsafe) import GHCJS.DOM.HTMLTableElement (HTMLTableElement (HTMLTableElement), getRows, setCellPadding, setCellSpacing) import GHCJS.DOM.HTMLTableRowElement (HTMLTableRowElement (HTMLTableRowElement), getCells) import GHCJS.DOM.KeyboardEvent (getAltGraphKey, getAltKey, getCtrlKey, getKey, getMetaKey, getShiftKey) import GHCJS.DOM.Node (appendChild_, replaceChild_, setTextContent) import GHCJS.DOM.NonElementParentNode (getElementByIdUnsafe) import GHCJS.DOM.RequestAnimationFrameCallback import GHCJS.DOM.Types (CSSStyleDeclaration, DOM, HTMLDivElement (HTMLDivElement), HTMLTableCellElement (HTMLTableCellElement), IsMouseEvent, Window, runDOM, unsafeCastTo) import GHCJS.DOM.WheelEvent (getDeltaY) import GHCJS.DOM.Window (requestAnimationFrame_) import Game.LambdaHack.Client.ClientOptions import Game.LambdaHack.Client.UI.Frame import Game.LambdaHack.Client.UI.Frontend.Common import qualified Game.LambdaHack.Client.UI.Key as K import qualified Game.LambdaHack.Common.Color as Color import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.Point import qualified Game.LambdaHack.Common.PointArray as PointArray -- | Session data maintained by the frontend. data FrontendSession = FrontendSession { scurrentWindow :: Window , scharCells :: V.Vector (HTMLTableCellElement, CSSStyleDeclaration) , spreviousFrame :: IORef SingleFrame } extraBlankMargin :: Int extraBlankMargin = 1 -- | The name of the frontend. frontendName :: String frontendName = "browser" -- | Starts the main program loop using the frontend input and output. startup :: ClientOptions -> IO RawFrontend startup soptions = do rfMVar <- newEmptyMVar flip runDOM undefined $ runWeb soptions rfMVar takeMVar rfMVar runWeb :: ClientOptions -> MVar RawFrontend -> DOM () runWeb soptions@ClientOptions{..} rfMVar = do -- Init the document. Just doc <- currentDocument Just scurrentWindow <- currentWindow body <- getBodyUnchecked doc pageStyle <- getStyle body setProp pageStyle "background-color" (Color.colorToRGB Color.Black) setProp pageStyle "color" (Color.colorToRGB Color.White) divBlockRaw <- createElement doc ("div" :: Text) divBlock <- unsafeCastTo HTMLDivElement divBlockRaw divStyle <- getStyle divBlock setProp divStyle "text-align" "center" let lxsize = fst normalLevelBound + 1 lysize = snd normalLevelBound + 4 cell = "" ++ [Char.chr 160] row = "" ++ concat (replicate (lxsize + extraBlankMargin * 2) cell) rows = concat (replicate (lysize + extraBlankMargin * 2) row) tableElemRaw <- createElement doc ("table" :: Text) tableElem <- unsafeCastTo HTMLTableElement tableElemRaw appendChild_ divBlock tableElem scharStyle <- getStyle tableElem -- Speed: setProp scharStyle "table-layout" "fixed" setProp scharStyle "font-family" "lambdaHackFont" setProp scharStyle "font-size" $ tshow (fromJust sfontSize) <> "px" setProp scharStyle "font-weight" "bold" setProp scharStyle "outline" "1px solid grey" setProp scharStyle "border-collapse" "collapse" setProp scharStyle "margin-left" "auto" setProp scharStyle "margin-right" "auto" -- Get rid of table spacing. Tons of spurious hacks just in case. setCellPadding tableElem ("0" :: Text) setCellSpacing tableElem ("0" :: Text) setProp scharStyle "padding" "0 0 0 0" setProp scharStyle "border-spacing" "0" setProp scharStyle "border" "none" -- Create the session record. setInnerHTML tableElem rows scharCells <- flattenTable tableElem spreviousFrame <- newIORef blankSingleFrame let sess = FrontendSession{..} rf <- IO.liftIO $ createRawFrontend (display soptions sess) shutdown let readMod = do modCtrl <- ask >>= getCtrlKey modShift <- ask >>= getShiftKey modAlt <- ask >>= getAltKey modMeta <- ask >>= getMetaKey modAltG <- ask >>= getAltGraphKey return $! modifierTranslate modCtrl modShift (modAlt || modAltG) modMeta void $ doc `on` keyDown $ do keyId <- ask >>= getKey modifier <- readMod -- This is currently broken at least for Shift-F1, etc., so won't be used: -- keyLoc <- ask >>= getKeyLocation -- let onKeyPad = case keyLoc of -- 3 {-KEY_LOCATION_NUMPAD-} -> True -- _ -> False let key = K.keyTranslateWeb keyId (modifier == K.Shift) modifierNoShift = -- to prevent S-!, etc. if modifier == K.Shift then K.NoModifier else modifier -- IO.liftIO $ do -- putStrLn $ "keyId: " ++ keyId -- putStrLn $ "key: " ++ K.showKey key -- putStrLn $ "modifier: " ++ show modifier when (key == K.Esc) $ IO.liftIO $ resetChanKey (fchanKey rf) IO.liftIO $ saveKMP rf modifierNoShift key originPoint -- Pass through C-+ and others, but disable special behaviour on Tab, etc. let browserKeys = "+-0tTnNdxcv" unless (modifier == K.Alt || modifier == K.Control && key `elem` map K.Char browserKeys) $ do preventDefault stopPropagation -- Handle mouseclicks, per-cell. let setupMouse i a = let Point x y = PointArray.punindex lxsize i in handleMouse rf a x y V.imapM_ setupMouse scharCells -- Display at the end to avoid redraw. Replace "Please wait". pleaseWait <- getElementByIdUnsafe doc ("pleaseWait" :: Text) replaceChild_ body divBlock pleaseWait IO.liftIO $ putMVar rfMVar rf -- send to client only after the whole webpage is set up -- because there is no @mainGUI@ to start accepting shutdown :: IO () shutdown = return () -- nothing to clean up setProp :: CSSStyleDeclaration -> Text -> Text -> DOM () setProp style propRef propValue = setProperty style propRef propValue (Nothing :: Maybe Text) -- | Let each table cell handle mouse events inside. handleMouse :: RawFrontend -> (HTMLTableCellElement, CSSStyleDeclaration) -> Int -> Int -> DOM () handleMouse rf (cell, _) cx cy = do let readMod :: IsMouseEvent e => EventM HTMLTableCellElement e K.Modifier readMod = do modCtrl <- mouseCtrlKey modShift <- mouseShiftKey modAlt <- mouseAltKey modMeta <- mouseMetaKey return $! modifierTranslate modCtrl modShift modAlt modMeta saveWheel = do wheelY <- ask >>= getDeltaY modifier <- readMod let mkey = if | wheelY < -0.01 -> Just K.WheelNorth | wheelY > 0.01 -> Just K.WheelSouth | otherwise -> Nothing -- probably a glitch pointer = Point cx cy maybe (return ()) (\key -> IO.liftIO $ saveKMP rf modifier key pointer) mkey saveMouse = do -- but <- mouseButton modifier <- readMod let key = case but of 0 -> K.LeftButtonRelease 1 -> K.MiddleButtonRelease 2 -> K.RightButtonRelease -- not handled in contextMenu _ -> K.LeftButtonRelease -- any other is alternate left pointer = Point cx cy -- IO.liftIO $ putStrLn $ -- "m: " ++ show but ++ show modifier ++ show pointer IO.liftIO $ saveKMP rf modifier key pointer void $ cell `on` wheel $ do saveWheel preventDefault stopPropagation void $ cell `on` contextMenu $ do preventDefault stopPropagation void $ cell `on` mouseUp $ do saveMouse preventDefault stopPropagation -- | Get the list of all cells of an HTML table. flattenTable :: HTMLTableElement -> DOM (V.Vector (HTMLTableCellElement, CSSStyleDeclaration)) flattenTable table = do let lxsize = fst normalLevelBound + 1 lysize = snd normalLevelBound + 4 rows <- getRows table let f y = do rowsItem <- itemUnsafe rows y unsafeCastTo HTMLTableRowElement rowsItem lrow <- mapM f [toEnum extraBlankMargin .. toEnum (lysize - 1 + extraBlankMargin)] let getC :: HTMLTableRowElement -> DOM [(HTMLTableCellElement, CSSStyleDeclaration)] getC row = do cells <- getCells row let g x = do cellsItem <- itemUnsafe cells x cell <- unsafeCastTo HTMLTableCellElement cellsItem style <- getStyle cell return (cell, style) mapM g [toEnum extraBlankMargin .. toEnum (lxsize - 1 + extraBlankMargin)] lrc <- mapM getC lrow return $! V.fromListN (lxsize * lysize) $ concat lrc -- | Output to the screen via the frontend. display :: ClientOptions -> FrontendSession -- ^ frontend session data -> SingleFrame -- ^ the screen frame to draw -> IO () display ClientOptions{scolorIsBold} FrontendSession{..} !curFrame = flip runDOM undefined $ do let setChar :: Int -> Word32 -> Word32 -> DOM () setChar !i !w !wPrev = unless (w == wPrev) $ do let Color.AttrChar{acAttr=Color.Attr{..}, acChar} = Color.attrCharFromW32 $ Color.AttrCharW32 w (!cell, !style) = scharCells V.! i case Char.ord acChar of 32 -> setTextContent cell $ Just [Char.chr 160] 183 | fg <= Color.BrBlack && scolorIsBold == Just True -> setTextContent cell $ Just [Char.chr 8901] _ -> setTextContent cell $ Just [acChar] setProp style "color" $ Color.colorToRGB fg case bg of Color.HighlightNone -> setProp style "border-color" "transparent" Color.HighlightRed -> setProp style "border-color" $ Color.colorToRGB Color.Red Color.HighlightBlue -> setProp style "border-color" $ Color.colorToRGB Color.Blue Color.HighlightYellow -> setProp style "border-color" $ Color.colorToRGB Color.BrYellow Color.HighlightGrey -> setProp style "border-color" $ Color.colorToRGB Color.BrBlack Color.HighlightWhite -> setProp style "border-color" $ Color.colorToRGB Color.White Color.HighlightMagenta -> setProp style "border-color" $ Color.colorToRGB Color.Magenta !prevFrame <- readIORef spreviousFrame writeIORef spreviousFrame curFrame -- This continues asynchronously, if can't otherwise. callback <- newRequestAnimationFrameCallbackSync $ \_ -> U.izipWithM_ setChar (PointArray.avector $ singleFrame curFrame) (PointArray.avector $ singleFrame prevFrame) -- This attempts to ensure no redraws while callback executes -- and a single redraw when it completes. requestAnimationFrame_ scurrentWindow callback LambdaHack-0.8.3.0/Game/LambdaHack/Client/UI/Frontend/Chosen.hs0000644000000000000000000000110613315545734021732 0ustar0000000000000000-- | Re-export the operations of the chosen raw frontend -- (determined at compile time with cabal flags). module Game.LambdaHack.Client.UI.Frontend.Chosen ( startup, frontendName ) where import Prelude () #ifdef USE_CURSES import Game.LambdaHack.Client.UI.Frontend.Curses #elif USE_VTY import Game.LambdaHack.Client.UI.Frontend.Vty #elif USE_GTK import Game.LambdaHack.Client.UI.Frontend.Gtk #elif USE_SDL import Game.LambdaHack.Client.UI.Frontend.Sdl #elif USE_BROWSER import Game.LambdaHack.Client.UI.Frontend.Dom #else import Game.LambdaHack.Client.UI.Frontend.Sdl #endif LambdaHack-0.8.3.0/Game/LambdaHack/Client/UI/Frontend/Sdl.hs0000644000000000000000000005471513315545734021253 0ustar0000000000000000-- | Text frontend based on SDL2. module Game.LambdaHack.Client.UI.Frontend.Sdl ( startup, frontendName #ifdef EXPOSE_INTERNAL -- * Internal operations , FontAtlas, FrontendSession(..), startupFun, shutdown, forceShutdown , display, drawFrame, printScreen, modTranslate, keyTranslate, colorToRGBA #endif ) where import Prelude () import Game.LambdaHack.Common.Prelude hiding (Alt) import Control.Concurrent import qualified Data.Char as Char import qualified Data.EnumMap.Strict as EM import Data.IORef import qualified Data.Text as T import Data.Time.Clock.POSIX import Data.Time.LocalTime import qualified Data.Vector.Unboxed as U import Data.Word (Word32, Word8) import Foreign.C.String (withCString) import Foreign.C.Types (CInt) import Foreign.Ptr (nullPtr) import Foreign.Storable (peek) import System.Directory import System.Exit (exitSuccess) import System.FilePath import qualified SDL import qualified SDL.Font as TTF import SDL.Input.Keyboard.Codes import qualified SDL.Internal.Types import qualified SDL.Raw.Basic as SDL (logSetAllPriority) import qualified SDL.Raw.Enum import qualified SDL.Raw.Types import qualified SDL.Raw.Video import qualified SDL.Vect as Vect import Game.LambdaHack.Client.ClientOptions import Game.LambdaHack.Client.UI.Frame import Game.LambdaHack.Client.UI.Frontend.Common import qualified Game.LambdaHack.Client.UI.Key as K import qualified Game.LambdaHack.Common.Color as Color import Game.LambdaHack.Common.File import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.Point import qualified Game.LambdaHack.Common.PointArray as PointArray type FontAtlas = EM.EnumMap Color.AttrCharW32 SDL.Texture -- | Session data maintained by the frontend. data FrontendSession = FrontendSession { swindow :: SDL.Window , srenderer :: SDL.Renderer , sfont :: TTF.Font , satlas :: IORef FontAtlas , stexture :: IORef SDL.Texture , spreviousFrame :: IORef SingleFrame , sforcedShutdown :: IORef Bool , scontinueSdlLoop :: IORef Bool , sframeQueue :: MVar SingleFrame , sframeDrawn :: MVar () } -- | The name of the frontend. frontendName :: String frontendName = "sdl" -- | Set up and start the main loop providing input and output. -- -- Because of Windows and OS X, SDL2 needs to be on a bound thread, -- so we can't avoid the communication overhead of bound threads. startup :: ClientOptions -> IO RawFrontend startup soptions = startupBound $ startupFun soptions startupFun :: ClientOptions -> MVar RawFrontend -> IO () startupFun soptions@ClientOptions{..} rfMVar = do SDL.initialize [SDL.InitVideo, SDL.InitEvents] -- lowest: pattern SDL_LOG_PRIORITY_VERBOSE = (1) :: LogPriority -- our default: pattern SDL_LOG_PRIORITY_ERROR = (5) :: LogPriority SDL.logSetAllPriority $ toEnum $ fromMaybe 5 slogPriority let title = fromJust stitle fontFileName = T.unpack (fromJust sdlFontFile) fontFile | isRelative fontFileName = fromJust sfontDir fontFileName | otherwise = fontFileName fontFileExists <- doesFileExist fontFile unless fontFileExists $ fail $ "Font file does not exist: " ++ fontFile let fontSize = fromJust sfontSize TTF.initialize sfont <- TTF.load fontFile fontSize let isFonFile = "fon" `isSuffixOf` T.unpack (fromJust sdlFontFile) sdlSizeAdd = fromJust $ if isFonFile then sdlFonSizeAdd else sdlTtfSizeAdd boxSize <- (+ sdlSizeAdd) <$> TTF.height sfont let xsize = fst normalLevelBound + 1 ysize = snd normalLevelBound + 4 screenV2 = SDL.V2 (toEnum $ xsize * boxSize) (toEnum $ ysize * boxSize) windowConfig = SDL.defaultWindow {SDL.windowInitialSize = screenV2} rendererConfig = SDL.RendererConfig { rendererType = if sbenchmark then SDL.AcceleratedRenderer else SDL.AcceleratedVSyncRenderer , rendererTargetTexture = True } swindow <- SDL.createWindow title windowConfig srenderer <- SDL.createRenderer swindow (-1) rendererConfig let initTexture = do texture <- SDL.createTexture srenderer SDL.ARGB8888 SDL.TextureAccessTarget screenV2 SDL.rendererRenderTarget srenderer SDL.$= Just texture SDL.rendererDrawBlendMode srenderer SDL.$= SDL.BlendNone SDL.rendererDrawColor srenderer SDL.$= colorToRGBA Color.Black SDL.clear srenderer -- clear the texture SDL.rendererRenderTarget srenderer SDL.$= Nothing SDL.copy srenderer texture Nothing Nothing -- clear the backbuffer return texture texture <- initTexture satlas <- newIORef EM.empty stexture <- newIORef texture spreviousFrame <- newIORef blankSingleFrame sforcedShutdown <- newIORef False scontinueSdlLoop <- newIORef True sframeQueue <- newEmptyMVar sframeDrawn <- newEmptyMVar let sess = FrontendSession{..} rfWithoutPrintScreen <- createRawFrontend (display sess) (shutdown sess) let rf = rfWithoutPrintScreen {fprintScreen = printScreen sess} putMVar rfMVar rf let pointTranslate :: forall i. (Enum i) => Vect.Point Vect.V2 i -> Point pointTranslate (SDL.P (SDL.V2 x y)) = Point (fromEnum x `div` boxSize) (fromEnum y `div` boxSize) redraw = do -- Textures may be trashed and even invalid, especially on Windows. atlas <- readIORef satlas writeIORef satlas EM.empty oldTexture <- readIORef stexture newTexture <- initTexture mapM_ SDL.destroyTexture $ EM.elems atlas SDL.destroyTexture oldTexture writeIORef stexture newTexture prevFrame <- readIORef spreviousFrame writeIORef spreviousFrame blankSingleFrame -- to overwrite each char drawFrame soptions sess prevFrame loopSDL :: IO () loopSDL = do me <- SDL.pollEvent -- events take precedence over frames case me of Nothing -> do mfr <- tryTakeMVar sframeQueue case mfr of Just fr -> do -- Don't present an unchanged backbuffer. -- This doesn't improve FPS; probably equal frames happen -- very rarely, if at all, which is actually very good. prevFrame <- readIORef spreviousFrame unless (prevFrame == fr) $ do -- Some SDL2 (OpenGL) backends are very thread-unsafe, -- so we need to ensure we draw on the same (bound) OS thread -- that initialized SDL, hence we have to poll frames. drawFrame soptions sess fr -- We can't print screen in @display@ due to thread-unsafety. when sprintEachScreen $ printScreen sess putMVar sframeDrawn () -- signal that drawing ended Nothing -> threadDelay $ if sbenchmark then 150 else 15000 -- 60 polls per second, so keyboard snappy enough; -- max 6000 FPS when benchmarking Just e -> handleEvent e continueSdlLoop <- readIORef scontinueSdlLoop if continueSdlLoop then loopSDL else do TTF.free sfont TTF.quit SDL.destroyRenderer srenderer SDL.destroyWindow swindow SDL.quit forcedShutdown <- readIORef sforcedShutdown when forcedShutdown exitSuccess -- not in the main thread, so no exit yet, see "Main" handleEvent e = case SDL.eventPayload e of SDL.KeyboardEvent keyboardEvent | SDL.keyboardEventKeyMotion keyboardEvent == SDL.Pressed -> do let sym = SDL.keyboardEventKeysym keyboardEvent ksm = SDL.keysymModifier sym shiftPressed = SDL.keyModifierLeftShift ksm || SDL.keyModifierRightShift ksm key = keyTranslate shiftPressed $ SDL.keysymKeycode sym modifier = modTranslate ksm p <- SDL.getAbsoluteMouseLocation when (key == K.Esc) $ resetChanKey (fchanKey rf) saveKMP rf modifier key (pointTranslate p) SDL.MouseButtonEvent mouseButtonEvent | SDL.mouseButtonEventMotion mouseButtonEvent == SDL.Released -> do md <- modTranslate <$> SDL.getModState let key = case SDL.mouseButtonEventButton mouseButtonEvent of SDL.ButtonLeft -> K.LeftButtonRelease SDL.ButtonMiddle -> K.MiddleButtonRelease SDL.ButtonRight -> K.RightButtonRelease _ -> K.LeftButtonRelease -- any other is spare left modifier = if md == K.Shift then K.NoModifier else md p = SDL.mouseButtonEventPos mouseButtonEvent saveKMP rf modifier key (pointTranslate p) SDL.MouseWheelEvent mouseWheelEvent -> do md <- modTranslate <$> SDL.getModState let SDL.V2 _ y = SDL.mouseWheelEventPos mouseWheelEvent mkey = case (compare y 0, SDL.mouseWheelEventDirection mouseWheelEvent) of (EQ, _) -> Nothing (LT, SDL.ScrollNormal) -> Just K.WheelSouth (GT, SDL.ScrollNormal) -> Just K.WheelNorth (LT, SDL.ScrollFlipped) -> Just K.WheelNorth (GT, SDL.ScrollFlipped) -> Just K.WheelSouth modifier = if md == K.Shift then K.NoModifier else md p <- SDL.getAbsoluteMouseLocation maybe (return ()) (\key -> saveKMP rf modifier key (pointTranslate p)) mkey SDL.WindowClosedEvent{} -> forceShutdown sess SDL.QuitEvent -> forceShutdown sess SDL.WindowRestoredEvent{} -> redraw SDL.WindowExposedEvent{} -> redraw -- needed on Windows -- Probably not needed, because textures nor their content not lost: -- SDL.WindowShownEvent{} -> redraw _ -> return () loopSDL shutdown :: FrontendSession -> IO () shutdown FrontendSession{..} = writeIORef scontinueSdlLoop False forceShutdown :: FrontendSession -> IO () forceShutdown sess@FrontendSession{..} = do writeIORef sforcedShutdown True shutdown sess -- | Add a frame to be drawn. display :: FrontendSession -- ^ frontend session data -> SingleFrame -- ^ the screen frame to draw -> IO () display FrontendSession{..} curFrame = do continueSdlLoop <- readIORef scontinueSdlLoop if continueSdlLoop then do putMVar sframeQueue curFrame -- Wait until the frame is drawn. takeMVar sframeDrawn else do forcedShutdown <- readIORef sforcedShutdown when forcedShutdown $ -- When there's a forced shutdown, ignore displaying one frame -- and don't occupy the CPU creating new ones and moving on with the game -- (possibly also saving the new game state, surprising the player), -- but delay the server and client thread(s) for a long time -- and let the SDL-init thread clean up and exit via @exitSuccess@ -- to avoid exiting via "thread blocked". threadDelay 50000 drawFrame :: ClientOptions -> FrontendSession -- ^ frontend session data -> SingleFrame -- ^ the screen frame to draw -> IO () drawFrame ClientOptions{..} FrontendSession{..} curFrame = do let isFonFile = "fon" `isSuffixOf` T.unpack (fromJust sdlFontFile) sdlSizeAdd = fromJust $ if isFonFile then sdlFonSizeAdd else sdlTtfSizeAdd boxSize <- (+ sdlSizeAdd) <$> TTF.height sfont let xsize = fst normalLevelBound + 1 vp :: Int -> Int -> Vect.Point Vect.V2 CInt vp x y = Vect.P $ Vect.V2 (toEnum x) (toEnum y) drawHighlight x y color = do SDL.rendererDrawColor srenderer SDL.$= colorToRGBA color let rect = SDL.Rectangle (vp (x * boxSize) (y * boxSize)) (Vect.V2 (toEnum boxSize) (toEnum boxSize)) SDL.drawRect srenderer $ Just rect SDL.rendererDrawColor srenderer SDL.$= colorToRGBA Color.Black -- reset back to black setChar :: Int -> Word32 -> Word32 -> IO () setChar i w wPrev = unless (w == wPrev) $ do atlas <- readIORef satlas let (y, x) = i `divMod` xsize acRaw = Color.AttrCharW32 w Color.AttrChar{acAttr=Color.Attr{..}, acChar=acCharRaw} = Color.attrCharFromW32 acRaw normalizeAc color = (Color.attrChar2ToW32 fg acCharRaw, Just color) (ac, mlineColor) = case bg of Color.HighlightNone -> (acRaw, Nothing) Color.HighlightRed -> normalizeAc Color.Red Color.HighlightBlue -> normalizeAc Color.Blue Color.HighlightYellow -> normalizeAc Color.BrYellow Color.HighlightGrey -> normalizeAc Color.BrBlack Color.HighlightWhite -> normalizeAc Color.White Color.HighlightMagenta -> normalizeAc Color.BrMagenta -- textTexture <- case EM.lookup ac atlas of Nothing -> do -- Make all visible floors bold (no bold fold variant for 16x16x, -- so only the dot can be bold). let acChar = if fg <= Color.BrBlack && Char.ord acCharRaw == 183 -- 0xb7 && scolorIsBold == Just True -- only dot but enough then Char.chr $ if isFonFile then 7 -- hack else 8901 -- 0x22c5 else acCharRaw textSurface <- TTF.shadedGlyph sfont (colorToRGBA fg) (colorToRGBA Color.Black) acChar textTexture <- SDL.createTextureFromSurface srenderer textSurface SDL.freeSurface textSurface writeIORef satlas $ EM.insert ac textTexture atlas -- not @acRaw@ return textTexture Just textTexture -> return textTexture ti <- SDL.queryTexture textTexture let box = SDL.Rectangle (vp (x * boxSize) (y * boxSize)) (Vect.V2 (toEnum boxSize) (toEnum boxSize)) width = min boxSize $ fromEnum $ SDL.textureWidth ti height = min boxSize $ fromEnum $ SDL.textureHeight ti xsrc = max 0 (fromEnum (SDL.textureWidth ti) - width) `div` 2 ysrc = max 0 (fromEnum (SDL.textureHeight ti) - height) `div` 2 srcR = SDL.Rectangle (vp xsrc ysrc) (Vect.V2 (toEnum width) (toEnum height)) xtgt = (boxSize - width) `divUp` 2 ytgt = (boxSize - height) `div` 2 tgtR = SDL.Rectangle (vp (x * boxSize + xtgt) (y * boxSize + ytgt)) (Vect.V2 (toEnum width) (toEnum height)) SDL.fillRect srenderer $ Just box SDL.copy srenderer textTexture (Just srcR) (Just tgtR) maybe (return ()) (drawHighlight x y) mlineColor texture <- readIORef stexture prevFrame <- readIORef spreviousFrame writeIORef spreviousFrame curFrame SDL.rendererRenderTarget srenderer SDL.$= Just texture SDL.rendererDrawColor srenderer SDL.$= colorToRGBA Color.Black U.izipWithM_ setChar (PointArray.avector $ singleFrame curFrame) (PointArray.avector $ singleFrame prevFrame) SDL.rendererRenderTarget srenderer SDL.$= Nothing SDL.copy srenderer texture Nothing Nothing -- clear the backbuffer SDL.present srenderer -- It can't seem to cope with SDL_PIXELFORMAT_INDEX8, so we are stuck -- with huge bitmaps. printScreen :: FrontendSession -> IO () printScreen FrontendSession{..} = do dataDir <- appDataDir tryCreateDir dataDir tryCreateDir $ dataDir "screenshots" utcTime <- getCurrentTime timezone <- getTimeZone utcTime let unspace = map $ \c -> case c of -- prevent the need for backquoting ' ' -> '_' ':' -> '.' _ -> c dateText = unspace $ take 25 $ show $ utcToLocalTime timezone utcTime fileName = dataDir "screenshots" "prtscn" <> dateText <.> "bmp" SDL.Internal.Types.Renderer renderer = srenderer Vect.V2 sw sh <- SDL.get $ SDL.windowSize swindow ptrOut <- SDL.Raw.Video.createRGBSurface 0 sw sh 32 0 0 0 0 surfaceOut <- peek ptrOut void $ SDL.Raw.Video.renderReadPixels renderer nullPtr SDL.Raw.Enum.SDL_PIXELFORMAT_ARGB8888 (SDL.Raw.Types.surfacePixels surfaceOut) (sw * 4) withCString fileName $ \fileNameCString -> void $! SDL.Raw.Video.saveBMP ptrOut fileNameCString SDL.Raw.Video.freeSurface ptrOut -- | Translates modifiers to our own encoding, ignoring Shift. modTranslate :: SDL.KeyModifier -> K.Modifier modTranslate m = modifierTranslate (SDL.keyModifierLeftCtrl m || SDL.keyModifierRightCtrl m) False (SDL.keyModifierLeftAlt m || SDL.keyModifierRightAlt m || SDL.keyModifierAltGr m) False keyTranslate :: Bool -> SDL.Keycode -> K.Key keyTranslate shiftPressed n = case n of KeycodeEscape -> K.Esc KeycodeReturn -> K.Return KeycodeBackspace -> K.BackSpace KeycodeTab -> if shiftPressed then K.BackTab else K.Tab KeycodeSpace -> K.Space KeycodeExclaim -> K.Char '!' KeycodeQuoteDbl -> K.Char '"' KeycodeHash -> K.Char '#' KeycodePercent -> K.Char '%' KeycodeDollar -> K.Char '$' KeycodeAmpersand -> K.Char '&' KeycodeQuote -> if shiftPressed then K.Char '"' else K.Char '\'' KeycodeLeftParen -> K.Char '(' KeycodeRightParen -> K.Char ')' KeycodeAsterisk -> K.Char '*' KeycodePlus -> K.Char '+' KeycodeComma -> if shiftPressed then K.Char '<' else K.Char ',' KeycodeMinus -> if shiftPressed then K.Char '_' else K.Char '-' KeycodePeriod -> if shiftPressed then K.Char '>' else K.Char '.' KeycodeSlash -> if shiftPressed then K.Char '?' else K.Char '/' Keycode1 -> if shiftPressed then K.Char '!' else K.Char '1' Keycode2 -> if shiftPressed then K.Char '@' else K.Char '2' Keycode3 -> if shiftPressed then K.Char '#' else K.Char '3' Keycode4 -> if shiftPressed then K.Char '$' else K.Char '4' Keycode5 -> if shiftPressed then K.Char '%' else K.Char '5' Keycode6 -> if shiftPressed then K.Char '^' else K.Char '6' Keycode7 -> if shiftPressed then K.Char '&' else K.Char '7' Keycode8 -> if shiftPressed then K.Char '*' else K.Char '8' Keycode9 -> if shiftPressed then K.Char '(' else K.Char '9' Keycode0 -> if shiftPressed then K.Char ')' else K.Char '0' KeycodeColon -> K.Char ':' KeycodeSemicolon -> if shiftPressed then K.Char ':' else K.Char ';' KeycodeLess -> K.Char '<' KeycodeEquals -> if shiftPressed then K.Char '+' else K.Char '=' KeycodeGreater -> K.Char '>' KeycodeQuestion -> K.Char '?' KeycodeAt -> K.Char '@' KeycodeLeftBracket -> if shiftPressed then K.Char '{' else K.Char '[' KeycodeBackslash -> if shiftPressed then K.Char '|' else K.Char '\\' KeycodeRightBracket -> if shiftPressed then K.Char '}' else K.Char ']' KeycodeCaret -> K.Char '^' KeycodeUnderscore -> K.Char '_' KeycodeBackquote -> if shiftPressed then K.Char '~' else K.Char '`' KeycodeUp -> K.Up KeycodeDown -> K.Down KeycodeLeft -> K.Left KeycodeRight -> K.Right KeycodeHome -> K.Home KeycodeEnd -> K.End KeycodePageUp -> K.PgUp KeycodePageDown -> K.PgDn KeycodeInsert -> K.Insert KeycodeDelete -> K.Delete KeycodePrintScreen -> K.PrintScreen KeycodeKPDivide -> K.KP '/' KeycodeKPMultiply -> K.KP '*' KeycodeKPMinus -> K.Char '-' -- KP and normal are merged here KeycodeKPPlus -> K.Char '+' -- KP and normal are merged here KeycodeKPEnter -> K.Return KeycodeKPEquals -> K.Return -- in case of some funny layouts KeycodeKP1 -> if shiftPressed then K.KP '1' else K.End KeycodeKP2 -> if shiftPressed then K.KP '2' else K.Down KeycodeKP3 -> if shiftPressed then K.KP '3' else K.PgDn KeycodeKP4 -> if shiftPressed then K.KP '4' else K.Left KeycodeKP5 -> if shiftPressed then K.KP '5' else K.Begin KeycodeKP6 -> if shiftPressed then K.KP '6' else K.Right KeycodeKP7 -> if shiftPressed then K.KP '7' else K.Home KeycodeKP8 -> if shiftPressed then K.KP '8' else K.Up KeycodeKP9 -> if shiftPressed then K.KP '9' else K.PgUp KeycodeKP0 -> if shiftPressed then K.KP '0' else K.Insert KeycodeKPPeriod -> K.Char '.' -- dot and comma are merged here KeycodeKPComma -> K.Char '.' -- to sidestep national standards KeycodeF1 -> K.Fun 1 KeycodeF2 -> K.Fun 2 KeycodeF3 -> K.Fun 3 KeycodeF4 -> K.Fun 4 KeycodeF5 -> K.Fun 5 KeycodeF6 -> K.Fun 6 KeycodeF7 -> K.Fun 7 KeycodeF8 -> K.Fun 8 KeycodeF9 -> K.Fun 9 KeycodeF10 -> K.Fun 10 KeycodeF11 -> K.Fun 11 KeycodeF12 -> K.Fun 12 KeycodeLCtrl -> K.DeadKey KeycodeLShift -> K.DeadKey KeycodeLAlt -> K.DeadKey KeycodeLGUI -> K.DeadKey KeycodeRCtrl -> K.DeadKey KeycodeRShift -> K.DeadKey KeycodeRAlt -> K.DeadKey KeycodeRGUI -> K.DeadKey KeycodeMode -> K.DeadKey KeycodeNumLockClear -> K.DeadKey KeycodeUnknown -> K.Unknown "KeycodeUnknown" _ -> let i = fromEnum $ unwrapKeycode n in if | 97 <= i && i <= 122 && shiftPressed -> K.Char $ Char.chr $ i - 32 | 32 <= i && i <= 126 -> K.Char $ Char.chr i | otherwise -> K.Unknown $ show n sDL_ALPHA_OPAQUE :: Word8 sDL_ALPHA_OPAQUE = 255 -- This code is sadly duplicated from "Game.LambdaHack.Common.Color". colorToRGBA :: Color.Color -> SDL.V4 Word8 colorToRGBA Color.Black = SDL.V4 0 0 0 sDL_ALPHA_OPAQUE colorToRGBA Color.Red = SDL.V4 0xD5 0x00 0x00 sDL_ALPHA_OPAQUE colorToRGBA Color.Green = SDL.V4 0x00 0xAA 0x00 sDL_ALPHA_OPAQUE colorToRGBA Color.Brown = SDL.V4 0xCA 0x4A 0x00 sDL_ALPHA_OPAQUE colorToRGBA Color.Blue = SDL.V4 0x20 0x3A 0xF0 sDL_ALPHA_OPAQUE colorToRGBA Color.Magenta = SDL.V4 0xAA 0x00 0xAA sDL_ALPHA_OPAQUE colorToRGBA Color.Cyan = SDL.V4 0x00 0xAA 0xAA sDL_ALPHA_OPAQUE colorToRGBA Color.White = SDL.V4 0xC5 0xBC 0xB8 sDL_ALPHA_OPAQUE colorToRGBA Color.BrBlack = SDL.V4 0x6F 0x5F 0x5F sDL_ALPHA_OPAQUE colorToRGBA Color.BrRed = SDL.V4 0xFF 0x55 0x55 sDL_ALPHA_OPAQUE colorToRGBA Color.BrGreen = SDL.V4 0x75 0xFF 0x45 sDL_ALPHA_OPAQUE colorToRGBA Color.BrYellow = SDL.V4 0xFF 0xE8 0x55 sDL_ALPHA_OPAQUE colorToRGBA Color.BrBlue = SDL.V4 0x40 0x90 0xFF sDL_ALPHA_OPAQUE colorToRGBA Color.BrMagenta = SDL.V4 0xFF 0x77 0xFF sDL_ALPHA_OPAQUE colorToRGBA Color.BrCyan = SDL.V4 0x60 0xFF 0xF0 sDL_ALPHA_OPAQUE colorToRGBA Color.BrWhite = SDL.V4 0xFF 0xFF 0xFF sDL_ALPHA_OPAQUE LambdaHack-0.8.3.0/Game/LambdaHack/Common/0000755000000000000000000000000013315545734016077 5ustar0000000000000000LambdaHack-0.8.3.0/Game/LambdaHack/Common/ContentData.hs0000644000000000000000000001774613315545734020656 0ustar0000000000000000{-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving, TypeFamilies #-} -- | A game requires the engine provided by the library, perhaps customized, -- and game content, defined completely afresh for the particular game. -- The possible kinds of content are fixed in the library and all defined -- within the library source code directory. On the other hand, game content, -- is defined in the directory hosting the particular game definition. -- -- Content of a given kind is just a list of content items. -- After the list is verified and the data preprocessed, it's held -- in the @ContentData@ datatype. module Game.LambdaHack.Common.ContentData ( ContentId(ContentId), ContentData, Freqs, Rarity , contentIdIndex, validateRarity, emptyContentData, makeContentData , okind, omemberGroup, oisSingletonGroup, ouniqGroup, opick , ofoldrWithKey, ofoldlWithKey', ofoldlGroup', omapVector, oimapVector , olength ) where import Prelude () import Game.LambdaHack.Common.Prelude import Control.DeepSeq import Data.Binary import Data.Function import Data.Hashable (Hashable) import qualified Data.Map.Strict as M import Data.Ord import qualified Data.Text as T import qualified Data.Vector as V import GHC.Generics (Generic) import Game.LambdaHack.Common.Frequency import Game.LambdaHack.Common.Misc import qualified Game.LambdaHack.Common.PointArray as PointArray import Game.LambdaHack.Common.Random -- | Content identifiers for the content type @c@. newtype ContentId c = ContentId Word16 deriving (Show, Eq, Ord, Enum, Binary, Generic) instance PointArray.UnboxRepClass (ContentId k) where type UnboxRep (ContentId k) = Word16 toUnboxRepUnsafe (ContentId k) = k fromUnboxRep = ContentId instance NFData (ContentId c) instance Hashable (ContentId c) -- | Verified and preprocessed content data of a particular kind. data ContentData c = ContentData { contentVector :: V.Vector c , groupFreq :: M.Map (GroupName c) [(Int, (ContentId c, c))] } deriving Generic instance NFData c => NFData (ContentData c) -- | 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)] maxContentId :: ContentId k maxContentId = ContentId maxBound contentIdIndex :: ContentId k -> Int {-# INLINE contentIdIndex #-} contentIdIndex (ContentId k) = fromEnum k 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 ] emptyContentData :: ContentData a emptyContentData = ContentData V.empty M.empty makeContentData :: (NFData c, Show c) => String -> (c -> Text) -- ^ name of the content itme, used for validation -> (c -> Freqs c) -- ^ frequency in groups, for validation and preprocessing -> (c -> [Text]) -- ^ validate a content item and list all offences -> ([c] -> ContentData c -> [Text]) -- ^ validate the whole defined content of this type -- and list all offence -> [c] -- ^ all content of this type -> ContentData c {-# INLINE makeContentData #-} makeContentData contentName getName getFreq validateSingle validateAll content = let contentVector = V.fromList content groupFreq = let tuples = [ (cgroup, (n, (i, k))) | (i, k) <- zip (map ContentId [0..]) content , (cgroup, n) <- getFreq k , n > 0 ] f m (cgroup, nik) = M.insertWith (++) cgroup [nik] m in foldl' f M.empty tuples cd = ContentData {..} -- Catch all kinds of errors in content ASAP, even in unused items. contentData = deepseq cd cd correct a = not (T.null (getName a)) && all ((> 0) . snd) (getFreq a) incorrectOffenders = filter (not . correct) content singleOffenders = [ (offences, a) | a <- content , let offences = validateSingle a , not (null offences) ] allOffences = validateAll content contentData in assert (null incorrectOffenders `blame` contentName ++ ": some content items not correct" `swith` incorrectOffenders) $ assert (null singleOffenders `blame` contentName ++ ": some content items not valid" `swith` singleOffenders) $ assert (null allOffences `blame` contentName ++ ": the content set is not valid" `swith` allOffences) $ assert (V.length contentVector <= contentIdIndex maxContentId `blame` contentName ++ ": the content has too many elements") contentData -- | Content element at given id. okind :: ContentData a -> ContentId a -> a {-# INLINE okind #-} okind ContentData{contentVector} !i = contentVector V.! contentIdIndex i omemberGroup :: ContentData a -> GroupName a -> Bool omemberGroup ContentData{groupFreq} cgroup = cgroup `M.member` groupFreq oisSingletonGroup :: ContentData a -> GroupName a -> Bool oisSingletonGroup ContentData{groupFreq} cgroup = case M.lookup cgroup groupFreq of Just [_] -> True _ -> False -- | The id of the unique member of a singleton content group. ouniqGroup :: Show a => ContentData a -> GroupName a -> ContentId a ouniqGroup ContentData{groupFreq} !cgroup = let freq = let assFail = error $ "no unique group" `showFailure` (cgroup, groupFreq) in M.findWithDefault assFail cgroup groupFreq in case freq of [(n, (i, _))] | n > 0 -> i l -> error $ "not unique" `showFailure` (cgroup, l) -- | Pick a random id belonging to a group and satisfying a predicate. opick :: Show a => ContentData a -> GroupName a -> (a -> Bool) -> Rnd (Maybe (ContentId a)) opick ContentData{groupFreq} !cgroup !p = case M.lookup cgroup groupFreq of Just freqRaw -> let freq = toFreq ("opick ('" <> tshow cgroup <> "')") $ filter (p . snd . snd) freqRaw in if nullFreq freq then return Nothing else Just . fst <$> frequency freq _ -> return Nothing -- | Fold over all content elements of @a@. ofoldrWithKey :: ContentData a -> (ContentId a -> a -> b -> b) -> b -> b ofoldrWithKey ContentData{contentVector} f z = V.ifoldr (\i c a -> f (ContentId $ toEnum i) c a) z contentVector -- | Fold strictly over all content @a@. ofoldlWithKey' :: ContentData a -> (b -> ContentId a -> a -> b) -> b -> b ofoldlWithKey' ContentData{contentVector} f z = V.ifoldl' (\a i c -> f a (ContentId $ toEnum i) c) z contentVector -- | Fold over the given group only. ofoldlGroup' :: ContentData a -> GroupName a -> (b -> Int -> ContentId a -> a -> b) -> b -> b ofoldlGroup' ContentData{groupFreq} cgroup f z = case M.lookup cgroup groupFreq of Just freq -> foldl' (\acc (p, (i, a)) -> f acc p i a) z freq _ -> error $ "no group '" ++ show cgroup ++ "' among content that has groups " ++ show (M.keys groupFreq) `showFailure` () omapVector :: ContentData a -> (a -> b) -> V.Vector b omapVector d f = V.map f $ contentVector d oimapVector :: ContentData a -> (ContentId a -> a -> b) -> V.Vector b oimapVector d f = V.imap (\i a -> f (ContentId $ toEnum i) a) $ contentVector d -- | Size of content @a@. olength :: ContentData a -> Int olength ContentData{contentVector} = V.length contentVector LambdaHack-0.8.3.0/Game/LambdaHack/Common/ItemAspect.hs0000644000000000000000000002524013315545734020474 0ustar0000000000000000{-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving #-} -- | The type of item aspects and its operations. module Game.LambdaHack.Common.ItemAspect ( Aspect(..), AspectRecord(..), KindMean(..), EqpSlot(..) , emptyAspectRecord, addMeanAspect, castAspect, aspectsRandom , sumAspectRecord, aspectRecordToList, rollAspectRecord, prEqpSlot #ifdef EXPOSE_INTERNAL -- * Internal operations , ceilingMeanDice #endif ) where import Prelude () import Game.LambdaHack.Common.Prelude import Control.DeepSeq import qualified Control.Monad.Trans.State.Strict as St import Data.Binary import qualified Data.EnumMap.Strict as EM import Data.Hashable (Hashable) import GHC.Generics (Generic) import qualified System.Random as R import qualified Game.LambdaHack.Common.Ability as Ability import qualified Game.LambdaHack.Common.Dice as Dice import Game.LambdaHack.Common.Random -- | 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 = Timeout Dice.Dice -- ^ some effects disabled until item recharges; -- expressed in game turns | AddHurtMelee Dice.Dice -- ^ percentage damage bonus in melee | AddArmorMelee Dice.Dice -- ^ percentage armor bonus against melee | AddArmorRanged Dice.Dice -- ^ percentage armor bonus against ranged | AddMaxHP Dice.Dice -- ^ maximal hp | AddMaxCalm Dice.Dice -- ^ maximal calm | AddSpeed Dice.Dice -- ^ speed in m/10s (not when pushed or pulled) | AddSight Dice.Dice -- ^ FOV radius, where 1 means a single tile FOV | AddSmell Dice.Dice -- ^ smell radius | AddShine Dice.Dice -- ^ shine radius | AddNocto Dice.Dice -- ^ noctovision radius | AddAggression Dice.Dice -- ^ aggression, e.g., when closing in for melee | AddAbility Ability.Ability Dice.Dice -- ^ bonus to an ability deriving (Show, Eq, Ord, Generic) -- | Record of sums of aspect values of an item, container, actor, etc. data AspectRecord = AspectRecord { aTimeout :: Int , aHurtMelee :: Int , aArmorMelee :: Int , aArmorRanged :: Int , aMaxHP :: Int , aMaxCalm :: Int , aSpeed :: Int , aSight :: Int , aSmell :: Int , aShine :: Int , aNocto :: Int , aAggression :: Int , aSkills :: Ability.Skills } deriving (Show, Eq, Ord, Generic) -- | Partial information about an item, deduced from its item kind. -- These are assigned to each 'ItemKind'. The @kmConst@ flag says whether -- the item's aspect record is constant rather than random or dependent -- on item creation dungeon level. data KindMean = KindMean { kmConst :: Bool -- ^ whether the item doesn't need second identification , kmMean :: AspectRecord -- ^ mean value of item's possible aspect records } deriving (Show, Eq, Ord, Generic) -- | AI and UI hints about the role of the item. data EqpSlot = EqpSlotMiscBonus | EqpSlotAddHurtMelee | EqpSlotAddArmorMelee | EqpSlotAddArmorRanged | EqpSlotAddMaxHP | EqpSlotAddSpeed | EqpSlotAddSight | EqpSlotLightSource | EqpSlotWeapon | EqpSlotMiscAbility | EqpSlotAbMove | EqpSlotAbMelee | EqpSlotAbDisplace | EqpSlotAbAlter | EqpSlotAbProject | EqpSlotAbApply -- Do not use in content: | EqpSlotAddMaxCalm | EqpSlotAddSmell | EqpSlotAddNocto | EqpSlotAddAggression | EqpSlotAbWait | EqpSlotAbMoveItem deriving (Show, Eq, Ord, Enum, Bounded, Generic) instance NFData Aspect instance NFData EqpSlot instance Hashable AspectRecord instance Binary AspectRecord emptyAspectRecord :: AspectRecord emptyAspectRecord = AspectRecord { aTimeout = 0 , aHurtMelee = 0 , aArmorMelee = 0 , aArmorRanged = 0 , aMaxHP = 0 , aMaxCalm = 0 , aSpeed = 0 , aSight = 0 , aSmell = 0 , aShine = 0 , aNocto = 0 , aAggression = 0 , aSkills = Ability.zeroSkills } castAspect :: Dice.AbsDepth -> Dice.AbsDepth -> AspectRecord -> Aspect -> Rnd AspectRecord castAspect !ldepth !totalDepth !ar !asp = case asp of Timeout d -> do n <- castDice ldepth totalDepth d return $! assert (aTimeout ar == 0) $ ar {aTimeout = n} AddHurtMelee d -> do n <- castDice ldepth totalDepth d return $! ar {aHurtMelee = n + aHurtMelee ar} AddArmorMelee d -> do n <- castDice ldepth totalDepth d return $! ar {aArmorMelee = n + aArmorMelee ar} AddArmorRanged d -> do n <- castDice ldepth totalDepth d return $! ar {aArmorRanged = n + aArmorRanged ar} AddMaxHP d -> do n <- castDice ldepth totalDepth d return $! ar {aMaxHP = n + aMaxHP ar} AddMaxCalm d -> do n <- castDice ldepth totalDepth d return $! ar {aMaxCalm = n + aMaxCalm ar} AddSpeed d -> do n <- castDice ldepth totalDepth d return $! ar {aSpeed = n + aSpeed ar} AddSight d -> do n <- castDice ldepth totalDepth d return $! ar {aSight = n + aSight ar} AddSmell d -> do n <- castDice ldepth totalDepth d return $! ar {aSmell = n + aSmell ar} AddShine d -> do n <- castDice ldepth totalDepth d return $! ar {aShine = n + aShine ar} AddNocto d -> do n <- castDice ldepth totalDepth d return $! ar {aNocto = n + aNocto ar} AddAggression d -> do n <- castDice ldepth totalDepth d return $! ar {aAggression = n + aAggression ar} AddAbility ab d -> do n <- castDice ldepth totalDepth d return $! ar {aSkills = Ability.addSkills (EM.singleton ab n) (aSkills ar)} -- If @False@, aspects of this kind are most probably fixed, not random -- nor dependent on dungeon level where the item is created. aspectsRandom :: [Aspect] -> Bool aspectsRandom ass = let rollM depth = foldlM' (castAspect (Dice.AbsDepth depth) (Dice.AbsDepth 10)) emptyAspectRecord ass gen = R.mkStdGen 0 (ar0, gen0) = St.runState (rollM 0) gen (ar1, gen1) = St.runState (rollM 10) gen0 in show gen /= show gen0 || show gen /= show gen1 || ar0 /= ar1 addMeanAspect :: AspectRecord -> Aspect -> AspectRecord addMeanAspect !ar !asp = case asp of Timeout d -> let n = ceilingMeanDice d in assert (aTimeout ar == 0) $ ar {aTimeout = n} AddHurtMelee d -> let n = ceilingMeanDice d in ar {aHurtMelee = n + aHurtMelee ar} AddArmorMelee d -> let n = ceilingMeanDice d in ar {aArmorMelee = n + aArmorMelee ar} AddArmorRanged d -> let n = ceilingMeanDice d in ar {aArmorRanged = n + aArmorRanged ar} AddMaxHP d -> let n = ceilingMeanDice d in ar {aMaxHP = n + aMaxHP ar} AddMaxCalm d -> let n = ceilingMeanDice d in ar {aMaxCalm = n + aMaxCalm ar} AddSpeed d -> let n = ceilingMeanDice d in ar {aSpeed = n + aSpeed ar} AddSight d -> let n = ceilingMeanDice d in ar {aSight = n + aSight ar} AddSmell d -> let n = ceilingMeanDice d in ar {aSmell = n + aSmell ar} AddShine d -> let n = ceilingMeanDice d in ar {aShine = n + aShine ar} AddNocto d -> let n = ceilingMeanDice d in ar {aNocto = n + aNocto ar} AddAggression d -> let n = ceilingMeanDice d in ar {aAggression = n + aAggression ar} AddAbility ab d -> let n = ceilingMeanDice d in ar {aSkills = Ability.addSkills (EM.singleton ab n) (aSkills ar)} ceilingMeanDice :: Dice.Dice -> Int ceilingMeanDice d = ceiling $ Dice.meanDice d sumAspectRecord :: [(AspectRecord, Int)] -> AspectRecord sumAspectRecord l = AspectRecord { aTimeout = 0 , aHurtMelee = sumScaled aHurtMelee , aArmorMelee = sumScaled aArmorMelee , aArmorRanged = sumScaled aArmorRanged , aMaxHP = sumScaled aMaxHP , aMaxCalm = sumScaled aMaxCalm , aSpeed = sumScaled aSpeed , aSight = sumScaled aSight , aSmell = sumScaled aSmell , aShine = sumScaled aShine , aNocto = sumScaled aNocto , aAggression = sumScaled aAggression , aSkills = sumScaledAbility } where sumScaled f = sum $ map (\(ar, k) -> f ar * k) l sumScaledAbility = EM.unionsWith (+) $ map (\(ar, k) -> Ability.scaleSkills k $ aSkills ar) l aspectRecordToList :: AspectRecord -> [Aspect] aspectRecordToList AspectRecord{..} = [Timeout $ Dice.intToDice aTimeout | aTimeout /= 0] ++ [AddHurtMelee $ Dice.intToDice aHurtMelee | aHurtMelee /= 0] ++ [AddArmorMelee $ Dice.intToDice aArmorMelee | aArmorMelee /= 0] ++ [AddArmorRanged $ Dice.intToDice aArmorRanged | aArmorRanged /= 0] ++ [AddMaxHP $ Dice.intToDice aMaxHP | aMaxHP /= 0] ++ [AddMaxCalm $ Dice.intToDice aMaxCalm | aMaxCalm /= 0] ++ [AddSpeed $ Dice.intToDice aSpeed | aSpeed /= 0] ++ [AddSight $ Dice.intToDice aSight | aSight /= 0] ++ [AddSmell $ Dice.intToDice aSmell | aSmell /= 0] ++ [AddShine $ Dice.intToDice aShine | aShine /= 0] ++ [AddNocto $ Dice.intToDice aNocto | aNocto /= 0] ++ [AddAggression $ Dice.intToDice aAggression | aAggression /= 0] ++ [AddAbility ab $ Dice.intToDice n | (ab, n) <- EM.assocs aSkills, n /= 0] rollAspectRecord :: [Aspect] -> Dice.AbsDepth -> Dice.AbsDepth -> Rnd AspectRecord rollAspectRecord ass ldepth totalDepth = foldlM' (castAspect ldepth totalDepth) emptyAspectRecord ass prEqpSlot :: EqpSlot -> AspectRecord -> Int prEqpSlot eqpSlot ar@AspectRecord{..} = case eqpSlot of EqpSlotMiscBonus -> aTimeout -- usually better items have longer timeout + aMaxCalm + aSmell + aNocto -- powerful, but hard to boost over aSight EqpSlotAddHurtMelee -> aHurtMelee EqpSlotAddArmorMelee -> aArmorMelee EqpSlotAddArmorRanged -> aArmorRanged EqpSlotAddMaxHP -> aMaxHP EqpSlotAddSpeed -> aSpeed EqpSlotAddSight -> aSight EqpSlotLightSource -> aShine EqpSlotWeapon -> error $ "" `showFailure` ar EqpSlotMiscAbility -> EM.findWithDefault 0 Ability.AbWait aSkills + EM.findWithDefault 0 Ability.AbMoveItem aSkills EqpSlotAbMove -> EM.findWithDefault 0 Ability.AbMove aSkills EqpSlotAbMelee -> EM.findWithDefault 0 Ability.AbMelee aSkills EqpSlotAbDisplace -> EM.findWithDefault 0 Ability.AbDisplace aSkills EqpSlotAbAlter -> EM.findWithDefault 0 Ability.AbAlter aSkills EqpSlotAbProject -> EM.findWithDefault 0 Ability.AbProject aSkills EqpSlotAbApply -> EM.findWithDefault 0 Ability.AbApply aSkills EqpSlotAddMaxCalm -> aMaxCalm EqpSlotAddSmell -> aSmell EqpSlotAddNocto -> aNocto EqpSlotAddAggression -> aAggression EqpSlotAbWait -> EM.findWithDefault 0 Ability.AbWait aSkills EqpSlotAbMoveItem -> EM.findWithDefault 0 Ability.AbMoveItem aSkills LambdaHack-0.8.3.0/Game/LambdaHack/Common/JSFile.hs0000644000000000000000000000577013315545734017560 0ustar0000000000000000-- | Saving/loading to JS storeage, mimicking operations on files. module Game.LambdaHack.Common.JSFile ( encodeEOF, strictDecodeEOF , tryCreateDir, doesFileExist, tryWriteFile, readFile, renameFile ) where import Prelude () import Game.LambdaHack.Common.Prelude import Data.Binary import qualified Data.ByteString.Lazy.Char8 as LBS import qualified Data.Text as T import Data.Text.Encoding (decodeLatin1) import GHCJS.DOM (currentWindow) import GHCJS.DOM.Storage (getItem, removeItem, setItem) import GHCJS.DOM.Types (runDOM) import GHCJS.DOM.Window (getLocalStorage) -- | Serialize and save data with an EOF marker. In JS, compression -- is probably performed by the browser and we don't have access -- to the zlib library anyway, so we don't compress here. -- 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 path a = flip runDOM undefined $ do Just win <- currentWindow storage <- getLocalStorage win setItem storage path $ decodeLatin1 $ LBS.toStrict $ encode (a, "OK" :: String) -- | Read 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 path = flip runDOM undefined $ do Just win <- currentWindow storage <- getLocalStorage win Just item <- getItem storage path let (a, n) = decode $ LBS.pack $ T.unpack item if n == ("OK" :: String) then return $! a else fail $ "Fatal error: corrupted file " ++ path -- | Try to create a directory; not needed with local storage in JS. tryCreateDir :: FilePath -> IO () tryCreateDir _dir = return () doesFileExist :: FilePath -> IO Bool doesFileExist path = flip runDOM undefined $ do Just win <- currentWindow storage <- getLocalStorage win mitem <- getItem storage path let fileExists = isJust (mitem :: Maybe String) return $! fileExists tryWriteFile :: FilePath -> String -> IO () tryWriteFile path content = flip runDOM undefined $ do Just win <- currentWindow storage <- getLocalStorage win mitem <- getItem storage path let fileExists = isJust (mitem :: Maybe String) unless fileExists $ setItem storage path content readFile :: FilePath -> IO String readFile path = flip runDOM undefined $ do Just win <- currentWindow storage <- getLocalStorage win mitem <- getItem storage path case mitem of Nothing -> fail $ "Fatal error: no file " ++ path Just item -> return item renameFile :: FilePath -> FilePath -> IO () renameFile path path2 = flip runDOM undefined $ do Just win <- currentWindow storage <- getLocalStorage win mitem <- getItem storage path case mitem :: Maybe String of Nothing -> fail $ "Fatal error: no file " ++ path Just item -> do setItem storage path2 item -- overwrites removeItem storage path LambdaHack-0.8.3.0/Game/LambdaHack/Common/Vector.hs0000644000000000000000000002245013315545734017700 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} -- | Basic operations on bounded 2D vectors, with an efficient, but not 1-1 -- and not monotonic @Enum@ instance. module Game.LambdaHack.Common.Vector ( Vector(..), isUnit, isDiagonal, neg, chessDistVector, euclidDistSqVector , moves, movesCardinal, movesDiagonal, compassText , vicinity, vicinityUnsafe, vicinityCardinal, vicinityCardinalUnsafe , squareUnsafeSet , shift, shiftBounded, trajectoryToPath, trajectoryToPathBounded , vectorToFrom, computeTrajectory , RadianAngle, rotate, towards #ifdef EXPOSE_INTERNAL -- * Internal operations , maxVectorDim, _moveTexts, longMoveTexts, normalize, normalizeVector , pathToTrajectory #endif ) where import Prelude () import Game.LambdaHack.Common.Prelude import Control.DeepSeq import Data.Binary import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES import Data.Int (Int32) import GHC.Generics (Generic) import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.Time -- | 2D vectors in cartesian representation. Coordinates grow to the right -- and down, so that the (1, 1) vector points to the bottom-right corner -- of the screen. data Vector = Vector { vx :: X , vy :: Y } deriving (Show, Read, Eq, Ord, Generic) instance Binary Vector where put = put . (fromIntegral :: Int -> Int32) . fromEnum get = fmap (toEnum . (fromIntegral :: Int32 -> Int)) get -- Note that the conversion is not monotonic wrt the natural @Ord@ instance, -- to keep it in sync with Point. instance Enum Vector where fromEnum (Vector vx vy) = vx + vy * (2 ^ maxLevelDimExponent) toEnum 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{..} instance NFData Vector -- | Maximal supported vector X and Y coordinates. maxVectorDim :: Int {-# INLINE maxVectorDim #-} maxVectorDim = 2 ^ (maxLevelDimExponent - 1) - 1 -- | 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) -- | The lenght of a vector in the chessboard metric, -- where diagonal moves cost 1. chessDistVector :: Vector -> Int {-# INLINE chessDistVector #-} chessDistVector (Vector x y) = max (abs x) (abs y) -- | Squared euclidean distance between two vectors. euclidDistSqVector :: Vector -> Vector -> Int euclidDistSqVector (Vector x0 y0) (Vector x1 y1) = (x1 - x0) ^ (2 :: Int) + (y1 - y0) ^ (2 :: Int) -- | Vectors of all unit moves in the chessboard metric, -- clockwise, starting north-west. moves :: [Vector] moves = map (uncurry Vector) [(-1, -1), (0, -1), (1, -1), (1, 0), (1, 1), (0, 1), (-1, 1), (-1, 0)] -- | Vectors of all cardinal direction unit moves, clockwise, starting north. movesCardinal :: [Vector] movesCardinal = map (uncurry Vector) [(0, -1), (1, 0), (0, 1), (-1, 0)] -- | Vectors of all diagonal direction unit moves, clockwise, starting north. movesDiagonal :: [Vector] movesDiagonal = map (uncurry Vector) [(-1, -1), (1, -1), (1, 1), (-1, 1)] -- | Currently unused. _moveTexts :: [Text] _moveTexts = ["NW", "N", "NE", "E", "SE", "S", "SW", "W"] longMoveTexts :: [Text] longMoveTexts = [ "northwest", "north", "northeast", "east" , "southeast", "south", "southwest", "west" ] compassText :: Vector -> Text compassText v = let m = EM.fromList $ zip moves longMoveTexts assFail = error $ "not a unit vector" `showFailure` v in EM.findWithDefault assFail v m -- | All (8 at most) closest neighbours of a point within an area. 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 = [ shift p dxy | dxy <- moves ] -- | All (4 at most) cardinal direction neighbours of a point within an area. vicinityCardinal :: X -> Y -- ^ limit the search to this area -> Point -- ^ position to find neighbours of -> [Point] vicinityCardinal lxsize lysize p = [ res | dxy <- movesCardinal , let res = shift p dxy , inside res (0, 0, lxsize - 1, lysize - 1) ] vicinityCardinalUnsafe :: Point -> [Point] vicinityCardinalUnsafe p = [ shift p dxy | dxy <- movesCardinal ] squareUnsafeSet :: Point -> ES.EnumSet Point squareUnsafeSet (Point x y) = ES.fromDistinctAscList $ map (uncurry Point) [ (x - 1, y - 1) , (x, y - 1) , (x + 1, y - 1) , (x - 1, y) , (x, y) -- full square, including the origin , (x + 1, y) , (x - 1, y + 1) , (x, y + 1) , (x + 1, y + 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 computeTrajectory :: Int -> Int -> Int -> [Point] -> ([Vector], (Speed, Int)) computeTrajectory weight throwVelocity throwLinger path = let speed = speedFromWeight weight throwVelocity trange = rangeFromSpeedAndLinger speed throwLinger btrajectory = pathToTrajectory $ take (trange + 1) path in (btrajectory, (speed, trange)) type RadianAngle = Double -- | Rotate a vector by the given angle (expressed in radians) -- counterclockwise and return a unit vector approximately in the resulting -- direction. rotate :: RadianAngle -> Vector -> Vector rotate angle (Vector x' y') = let x = 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 -- | Given a vector of arbitrary non-zero length, produce a unit vector -- that points in the same direction (in the chessboard metric). -- Of several equally good directions it picks one of those that visually -- (in the euclidean metric) maximally align with the original vector. normalize :: Double -> Double -> Vector normalize dx dy = assert (dx /= 0 || dy /= 0 `blame` "can't normalize zero" `swith` (dx, dy)) $ let angle :: Double angle = atan (dy / dx) / (pi / 2) dxy | angle <= -0.75 && angle >= -1.25 = (0, -1) | angle <= -0.25 = (1, -1) | angle <= 0.25 = (1, 0) | angle <= 0.75 = (1, 1) | angle <= 1.25 = (0, 1) | otherwise = error $ "impossible angle" `showFailure` (dx, dy, angle) in if dx >= 0 then uncurry Vector dxy else neg $ uncurry Vector dxy normalizeVector :: Vector -> Vector normalizeVector v@(Vector vx vy) = let res = normalize (fromIntegral vx) (fromIntegral vy) in assert (not (isUnit v) || v == res `blame` "unit vector gets untrivially normalized" `swith` (v, res)) res -- | Given two distinct positions, determine the direction (a unit vector) -- in which one should move from the first in order to get closer -- to the second. Ignores obstacles. Of several equally good directions -- (in the chessboard metric) it picks one of those that visually -- (in the euclidean metric) maximally align with the vector between -- the two points. towards :: Point -> Point -> Vector towards pos0 pos1 = assert (pos0 /= pos1 `blame` "towards self" `swith` (pos0, pos1)) $ normalizeVector $ pos1 `vectorToFrom` pos0 LambdaHack-0.8.3.0/Game/LambdaHack/Common/Misc.hs0000644000000000000000000002140413315545734017327 0ustar0000000000000000{-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving, TypeFamilies #-} {-# OPTIONS_GHC -Wno-orphans #-} -- | Hacks that haven't found their home yet. module Game.LambdaHack.Common.Misc ( -- * Game object identifiers FactionId, LevelId, ActorId -- * Item containers , Container(..), CStore(..), SLore(..), ItemDialogMode(..) -- * Assorted , GroupName, Tactic(..) , toGroupName, describeTactic , makePhrase, makeSentence, squashedWWandW, normalLevelBound , appDataDir, xM, xD, minusM, minusM1, oneM, tenthM , workaroundOnMainThreadMVar ) where import Prelude () import Game.LambdaHack.Common.Prelude import Control.Concurrent import Control.DeepSeq import Data.Binary import qualified Data.Char as Char import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES import qualified Data.Fixed as Fixed import Data.Hashable import qualified Data.HashMap.Strict as HM import Data.Int (Int64) import Data.Key import Data.String (IsString (..)) import qualified Data.Text as T import qualified Data.Time as Time import GHC.Generics (Generic) import qualified NLP.Miniutter.English as MU import System.Directory (getAppUserDataDirectory) import System.Environment (getProgName) import System.IO.Unsafe (unsafePerformIO) import Game.LambdaHack.Common.Point -- | A unique identifier of a faction in a game. newtype FactionId = FactionId Int deriving (Show, Eq, Ord, Enum, Hashable, Binary) -- | Abstract level identifiers. newtype LevelId = LevelId Int deriving (Show, Eq, Ord, Hashable, Binary) instance Enum LevelId where fromEnum (LevelId n) = n toEnum = LevelId -- picks the main branch of the dungeon -- | A unique identifier of an actor in the dungeon. newtype ActorId = ActorId Int deriving (Show, Eq, Ord, Enum, Binary) -- | Item container type. data Container = CFloor LevelId Point | CEmbed LevelId Point | CActor ActorId CStore | CTrunk FactionId LevelId Point -- ^ for bootstrapping actor bodies deriving (Show, Eq, Ord, Generic) instance Binary Container -- | Actor's item stores. data CStore = CGround | COrgan | CEqp | CInv | CSha deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic) instance Binary CStore instance NFData CStore -- | Item slot and lore categories. data SLore = SItem | SOrgan | STrunk | STmp | SBlast | SEmbed deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic) instance Binary SLore instance NFData SLore data ItemDialogMode = MStore CStore | MOrgans | MOwned | MStats | MLore SLore deriving (Show, Read, Eq, Ord, Generic) instance NFData ItemDialogMode instance Binary ItemDialogMode -- 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 (Read, Eq, Ord, 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) -- | 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 deriving (Eq, Ord, Enum, Bounded, Generic) instance Show Tactic where show TExplore = "explore" show TFollow = "follow freely" show TFollowNoItems = "follow only" show TMeleeAndRanged = "fight only" show TMeleeAdjacent = "melee only" show TBlock = "block only" show TRoam = "roam freely" show TPatrol = "patrol area" instance Binary Tactic instance NFData Tactic toGroupName :: Text -> GroupName a {-# INLINE toGroupName #-} toGroupName = GroupName describeTactic :: Tactic -> Text describeTactic TExplore = "investigate unknown positions, chase targets" describeTactic TFollow = "follow leader's target or position, grab items" describeTactic TFollowNoItems = "follow leader's target or position, ignore items" describeTactic TMeleeAndRanged = "engage in both melee and ranged combat, don't move" describeTactic TMeleeAdjacent = "engage exclusively in melee, don't move" describeTactic TBlock = "block and wait, don't move" describeTactic TRoam = "move freely, chase targets" describeTactic TPatrol = "find and patrol an area (WIP)" -- | 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 -- | Apply the @WWandW@ constructor, first representing repetitions -- as @CardinalWs@. -- The parts are not sorted, only grouped, to keep the order. -- The internal structure of speech parts is compared, not their string -- rendering, so some coincidental clashes are avoided (and code is simpler). squashedWWandW :: [MU.Part] -> (MU.Part, MU.Person) squashedWWandW parts = let repetitions = group parts f [] = error $ "empty group" `showFailure` parts f [part] = (part, MU.Sg3rd) -- avoid prefixing hero names with "a" f l@(part : _) = (MU.CardinalWs (length l) part, MU.PlEtc) cars = map f repetitions person = case cars of [] -> error $ "empty cars" `showFailure` parts [(_, person1)] -> person1 _ -> MU.PlEtc in (MU.WWandW $ map fst cars, person) -- | Level bounds. normalLevelBound :: (Int, Int) normalLevelBound = (79, 20) -- | 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 xM :: Int -> Int64 xM k = fromIntegral k * 1000000 xD :: Double -> Double xD k = k * 1000000 minusM, minusM1, oneM, tenthM :: Int64 minusM = xM (-1) minusM1 = xM (-1) - 1 oneM = xM 1 tenthM = 100000 -- Global variable for passing the action to run on main thread, if any. workaroundOnMainThreadMVar :: MVar (IO ()) {-# NOINLINE workaroundOnMainThreadMVar #-} workaroundOnMainThreadMVar = unsafePerformIO newEmptyMVar -- Data.Binary orphan instances instance (Enum k, Binary k, Binary e) => Binary (EM.EnumMap k e) where put m = put (EM.size m) >> mapM_ put (EM.toAscList m) get = EM.fromDistinctAscList <$> get instance (Enum k, Binary k) => Binary (ES.EnumSet k) where put m = put (ES.size m) >> mapM_ put (ES.toAscList m) get = ES.fromDistinctAscList <$> get instance Binary Time.NominalDiffTime where get = fmap realToFrac (get :: Get Fixed.Pico) put = (put :: Fixed.Pico -> Put) . realToFrac instance (Hashable k, Eq k, Binary k, Binary v) => Binary (HM.HashMap k v) where get = fmap HM.fromList get put = put . HM.toList -- Data.Key orphan instances type instance Key (EM.EnumMap k) = k instance Zip (EM.EnumMap k) where {-# INLINE zipWith #-} zipWith = EM.intersectionWith instance Enum k => ZipWithKey (EM.EnumMap k) where {-# INLINE zipWithKey #-} zipWithKey = EM.intersectionWithKey instance Enum k => Keyed (EM.EnumMap k) where {-# INLINE mapWithKey #-} mapWithKey = EM.mapWithKey instance Enum k => FoldableWithKey (EM.EnumMap k) where {-# INLINE foldrWithKey #-} foldrWithKey = EM.foldrWithKey instance Enum k => TraversableWithKey (EM.EnumMap k) where traverseWithKey f = fmap EM.fromDistinctAscList . traverse (\(k, v) -> (,) k <$> f k v) . EM.toAscList instance Enum k => Indexable (EM.EnumMap k) where {-# INLINE index #-} index = (EM.!) instance Enum k => Lookup (EM.EnumMap k) where {-# INLINE lookup #-} lookup = EM.lookup instance Enum k => Adjustable (EM.EnumMap k) where {-# INLINE adjust #-} adjust = EM.adjust -- Data.Hashable orphan instances instance (Enum k, Hashable k, Hashable e) => Hashable (EM.EnumMap k e) where hashWithSalt s x = hashWithSalt s (EM.toAscList x) -- Control.DeepSeq orphan instances instance NFData MU.Part instance NFData MU.Person instance NFData MU.Polarity LambdaHack-0.8.3.0/Game/LambdaHack/Common/Frequency.hs0000644000000000000000000001024213315545734020373 0ustar0000000000000000{-# LANGUAGE DeriveFoldable, DeriveGeneric, DeriveTraversable #-} -- | A list of entities 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 , minFreq, maxFreq, mostFreq ) where import Prelude () import Game.LambdaHack.Common.Prelude import Control.Applicative import Data.Int (Int32) import Data.Ord (comparing) import GHC.Generics (Generic) -- | 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. data Frequency a = Frequency { runFrequency :: [(Int, a)] -- ^ give acces to raw frequency values , nameFrequency :: Text -- ^ short description for debug, etc. } deriving (Show, Eq, Ord, Foldable, Traversable, Generic) _maxBound32 :: Integer _maxBound32 = toInteger (maxBound :: Int32) instance Monad Frequency where Frequency xs name >>= f = Frequency [ #ifdef WITH_EXPENSIVE_ASSERTIONS assert (toInteger p * toInteger q <= _maxBound32) #endif (p * q, y) | (p, x) <- xs , (q, y) <- runFrequency (f x) ] ("bind (" <> name <> ")") instance Functor Frequency where fmap f (Frequency xs name) = Frequency (map (second f) xs) name instance Applicative Frequency where {-# INLINE pure #-} pure x = Frequency [(1, x)] "pure" Frequency fs fname <*> Frequency ys yname = Frequency [ #ifdef WITH_EXPENSIVE_ASSERTIONS assert (toInteger p * toInteger q <= _maxBound32) #endif (p * q, f y) | (p, f) <- fs , (q, y) <- ys ] ("(" <> fname <> ") <*> (" <> yname <> ")") instance MonadPlus Frequency where mplus (Frequency xs xname) (Frequency ys yname) = let name = case (xs, ys) of ([], []) -> "[]" ([], _ ) -> yname (_, []) -> xname _ -> "(" <> xname <> ") ++ (" <> yname <> ")" in Frequency (xs ++ ys) name mzero = Frequency [] "[]" instance Alternative Frequency where (<|>) = mplus empty = mzero -- | Uniform discrete frequency distribution. uniformFreq :: Text -> [a] -> Frequency a uniformFreq name l = Frequency (map (\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 = #ifdef WITH_EXPENSIVE_ASSERTIONS assert (all (\(p, _) -> toInteger p <= _maxBound32) l) $ #endif Frequency (filter ((> 0 ) . fst) l) name -- | Scale frequency distribution, multiplying it -- by a positive integer constant. scaleFreq :: Show a => Int -> Frequency a -> Frequency a scaleFreq n (Frequency xs name) = assert (n > 0 `blame` "non-positive frequency scale" `swith` (name, n, xs)) $ let multN p = #ifdef WITH_EXPENSIVE_ASSERTIONS assert (toInteger p * toInteger n <= _maxBound32) $ #endif p * n in Frequency (map (first multN) 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 nullFreq (Frequency fs _) = null fs minFreq :: Ord a => Frequency a -> Maybe a minFreq fr = if nullFreq fr then Nothing else Just $ minimum fr maxFreq :: Ord a => Frequency a -> Maybe a maxFreq fr = if nullFreq fr then Nothing else Just $ maximum fr mostFreq :: Frequency a -> Maybe a mostFreq fr = if nullFreq fr then Nothing else Just $ snd $ maximumBy (comparing fst) $ runFrequency fr LambdaHack-0.8.3.0/Game/LambdaHack/Common/Dice.hs0000644000000000000000000002126313315545734017303 0ustar0000000000000000{-# LANGUAGE DeriveGeneric, FlexibleInstances, GeneralizedNewtypeDeriving, TypeSynonymInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} -- | Representation of dice scaled with current level depth. module Game.LambdaHack.Common.Dice ( -- * Frequency distribution for casting dice scaled with level depth Dice, AbsDepth(..), castDice, d, dL, z, zL, intToDice , minmaxDice, maxDice, minDice, meanDice, reduceDice -- * Dice for rolling a pair of integer parameters representing coordinates. , DiceXY(..), maxDiceXY, minDiceXY, meanDiceXY ) where import Prelude () import Game.LambdaHack.Common.Prelude import Control.DeepSeq import Data.Binary import Data.Hashable (Hashable) import GHC.Generics (Generic) -- | Multiple dice rolls, some scaled with current level depth, in which case -- the sum of all rolls is scaled in proportion to current depth -- divided by maximal dungeon depth. -- -- The simple dice should have positive number of rolls and number of sides. -- -- The @Num@ instance doesn't have @abs@ nor @signum@ defined, -- because the functions for computing minimum, maximum and mean dice -- results would be too costly. data Dice = DiceI Int | DiceD Int Int | DiceDL Int Int | DiceZ Int Int | DiceZL Int Int | DicePlus Dice Dice | DiceTimes Dice Dice | DiceNegate Dice deriving (Eq, Ord, Generic) instance Show Dice where show = stripOuterParens . showDiceWithParens stripOuterParens :: String -> String stripOuterParens s@('(' : rest) = case uncons $ reverse rest of Just (')', middle) -> reverse middle _ -> s stripOuterParens s = s showDiceWithParens :: Dice -> String showDiceWithParens = sh where sh dice1 = case dice1 of DiceI k -> show k DiceD n k -> show n ++ "d" ++ show k DiceDL n k -> show n ++ "dL" ++ show k DiceZ n k -> show n ++ "z" ++ show k DiceZL n k -> show n ++ "zL" ++ show k DicePlus d1 (DiceNegate d2) -> wrapInParens $ sh d1 ++ "-" ++ sh d2 DicePlus (DiceNegate d1) d2 -> wrapInParens $ "-" ++ sh d1 ++ "+" ++ sh d2 DicePlus d1 (DicePlus d2 d3) -> sh $ DicePlus (DicePlus d1 d2) d3 DicePlus (DicePlus d1 d2) d3 -> wrapInParens $ stripOuterParens (sh $ DicePlus d1 d2) ++ "+" ++ sh d3 DicePlus d1 d2 -> wrapInParens $ sh d1 ++ "+" ++ sh d2 DiceTimes d1 d2 -> wrapInParens $ sh d1 ++ "*" ++ sh d2 DiceNegate d1 -> wrapInParens $ "-" ++ sh d1 wrapInParens :: String -> String wrapInParens "" = "" wrapInParens t = "(" <> t <> ")" instance Binary Dice instance NFData Dice instance Num Dice where d1 + d2 = DicePlus d1 d2 d1 * d2 = DiceTimes d1 d2 d1 - d2 = d1 + DiceNegate d2 negate = DiceNegate abs = undefined signum = undefined fromInteger n = DiceI (fromInteger n) -- | Absolute depth in the dungeon. When used for the maximum depth -- of the whole dungeon, this can be different than dungeon size, -- e.g., when the dungeon is branched, and it can even be different -- than the length of the longest branch, if levels at some depths are missing. newtype AbsDepth = AbsDepth Int deriving (Show, Eq, Ord, Hashable, Binary) -- | Cast dice scaled with current level depth. When scaling, we round up, -- so that the value of @1 `dL` 1@ is 1 even at the lowest level. -- -- The implementation calls RNG as many times as there are dice rolls, -- which is costly, so content should prefer to case fewer dice -- and then multiply them by a constant. If rounded results are not desired -- (often they are, to limit the number of distinct item varieties -- in inventory), another dice may be added to the result. -- -- A different possible implementation, with dice represented as 'Frequency', -- makes only one RNG call per dice, but due to lists lengths proportional -- to the maximal value of the dice, it's is intractable for 1000d1000 -- and problematic already for 100d100. castDice :: forall m. Monad m => ((Int, Int) -> m Int) -> AbsDepth -> AbsDepth -> Dice -> m Int castDice randomR (AbsDepth lvlDepth) (AbsDepth maxDepth) dice = do let !_A = assert (lvlDepth >= 0 && lvlDepth <= maxDepth `blame` "invalid depth for dice rolls" `swith` (lvlDepth, maxDepth)) () castNK n start k = if start == k then return $! n * k else do let f !acc 0 = return acc f acc count = do r <- randomR (start, k) f (acc + r) (count - 1) f 0 n scaleL k = (k * max 1 lvlDepth) `divUp` max 1 maxDepth castD :: Dice -> m Int castD dice1 = case dice1 of DiceI k -> return k DiceD n k -> castNK n 1 k DiceDL n k -> scaleL <$> castNK n 1 k DiceZ n k -> castNK n 0 (k - 1) DiceZL n k -> scaleL <$> castNK n 0 (k - 1) DicePlus d1 d2 -> do k1 <- castD d1 k2 <- castD d2 return $! k1 + k2 DiceTimes d1 d2 -> do k1 <- castD d1 k2 <- castD d2 return $! k1 * k2 DiceNegate d1 -> do k <- castD d1 return $! negate k castD dice -- | A die, rolled the given number of times. E.g., @1 `d` 2@ rolls 2-sided -- die one time. d :: Int -> Int -> Dice d n k = assert (n > 0 && k > 0 `blame` "die must be positive" `swith` (n, k)) $ DiceD n k -- | A die rolled the given number of times, with the result scaled -- with dungeon level depth. dL :: Int -> Int -> Dice dL n k = assert (n > 0 && k > 0 `blame` "die must be positive" `swith` (n, k)) $ DiceDL n k -- | A die, starting from zero, ending at one less than the bound, -- rolled the given number of times. E.g., @1 `z` 1@ always rolls zero. z :: Int -> Int -> Dice z n k = assert (n > 0 && k > 0 `blame` "die must be positive" `swith` (n, k)) $ DiceZ n k -- | A die, starting from zero, ending at one less than the bound, -- rolled the given number of times, -- with the result scaled with dungeon level depth. zL :: Int -> Int -> Dice zL n k = assert (n > 0 && k > 0 `blame` "die must be positive" `swith` (n, k)) $ DiceZL n k intToDice :: Int -> Dice intToDice = DiceI -- | Minimal and maximal possible value of the dice. -- -- @divUp@ in the implementation corresponds to @ceiling@, -- applied to results of @meanDice@ elsewhere in the code, -- and prevents treating 1d1-power effects (on shallow levels) as null effects. minmaxDice :: Dice -> (Int, Int) minmaxDice dice1 = case dice1 of DiceI k -> (k, k) DiceD n k -> (n, n * k) DiceDL n k -> (1, n * k) -- bottom and top level considered DiceZ n k -> (0, n * (k - 1)) DiceZL n k -> (0, n * (k - 1)) -- bottom and top level considered DicePlus d1 d2 -> let (minD1, maxD1) = minmaxDice d1 (minD2, maxD2) = minmaxDice d2 in (minD1 + minD2, maxD1 + maxD2) DiceTimes (DiceI k) d2 -> let (minD2, maxD2) = minmaxDice d2 in if k >= 0 then (k * minD2, k * maxD2) else (k * maxD2, k * minD2) DiceTimes d1 (DiceI k) -> let (minD1, maxD1) = minmaxDice d1 in if k >= 0 then (minD1 * k, maxD1 * k) else (maxD1 * k, minD1 * k) -- Multiplication other than the two cases above is unlikely, but here it is. DiceTimes d1 d2 -> let (minD1, maxD1) = minmaxDice d1 (minD2, maxD2) = minmaxDice d2 options = [minD1 * minD2, minD1 * maxD2, maxD1 * maxD2, maxD1 * minD2] in (minimum options, maximum options) DiceNegate d1 -> let (minD1, maxD1) = minmaxDice d1 in (negate maxD1, negate minD1) -- | Maximal value of dice. The scaled part taken assuming median level. maxDice :: Dice -> Int maxDice = snd . minmaxDice -- | Minimal value of dice. The scaled part taken assuming median level. minDice :: Dice -> Int minDice = fst . minmaxDice -- | Mean value of dice. The scaled part taken assuming median level. meanDice :: Dice -> Double meanDice dice1 = case dice1 of DiceI k -> fromIntegral k DiceD n k -> fromIntegral (n * (k + 1)) / 2 DiceDL n k -> fromIntegral (n * (k + 1)) / 4 DiceZ n k -> fromIntegral (n * k) / 2 DiceZL n k -> fromIntegral (n * k) / 4 DicePlus d1 d2 -> meanDice d1 + meanDice d2 DiceTimes d1 d2 -> meanDice d1 * meanDice d2 -- I hope this is that simple DiceNegate d1 -> negate $ meanDice d1 reduceDice :: Dice -> Maybe Int reduceDice d1 = let (minD1, maxD1) = minmaxDice d1 in if minD1 == maxD1 then Just minD1 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, Generic) instance Binary DiceXY instance NFData 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 -> (Double, Double) meanDiceXY (DiceXY x y) = (meanDice x, meanDice y) LambdaHack-0.8.3.0/Game/LambdaHack/Common/Kind.hs0000644000000000000000000000324713315545734017326 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} -- | General content types and operations. module Game.LambdaHack.Common.Kind ( ContentId, ContentData, COps(..) , emptyCOps, getStdRuleset , okind, ouniqGroup, opick , ofoldrWithKey, ofoldlWithKey', ofoldlGroup', omapVector, oimapVector , olength ) where import Prelude () import Game.LambdaHack.Common.Prelude import GHC.Generics (Generic) import Game.LambdaHack.Common.ContentData 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 -- | Operations for all content types, gathered together. data COps = COps { cocave :: ContentData CaveKind -- server only , coitem :: ContentData ItemKind , comode :: ContentData ModeKind -- server only , coplace :: ContentData PlaceKind -- server only, so far , corule :: ContentData RuleKind , cotile :: ContentData TileKind , coItemSpeedup :: ItemSpeedup , coTileSpeedup :: TileSpeedup } deriving Generic instance Show COps where show _ = "game content" instance Eq COps where (==) _ _ = True emptyCOps :: COps emptyCOps = COps { cocave = emptyContentData , coitem = emptyContentData , comode = emptyContentData , coplace = emptyContentData , corule = emptyContentData , cotile = emptyContentData , coItemSpeedup = emptyItemSpeedup , coTileSpeedup = emptyTileSpeedup } -- | The standard ruleset used for level operations. getStdRuleset :: COps -> RuleKind getStdRuleset COps{corule} = okind corule $ ouniqGroup corule "standard" LambdaHack-0.8.3.0/Game/LambdaHack/Common/Time.hs0000644000000000000000000002464113315545734017340 0ustar0000000000000000{-# LANGUAGE DeriveFunctor, GeneralizedNewtypeDeriving #-} -- | Game time and speed. module Game.LambdaHack.Common.Time ( Time, timeZero, timeEpsilon, timeClip, timeTurn, timeSecond , absoluteTimeAdd, absoluteTimeSubtract, absoluteTimeNegate , timeFit, timeFitUp , Delta(..), timeShift, timeDeltaToFrom, timeDeltaAdd, timeDeltaSubtract , timeDeltaReverse, timeDeltaScale, timeDeltaPercent, timeDeltaDiv , timeDeltaToDigit , Speed, toSpeed, fromSpeed, minSpeed , speedZero, speedWalk, speedLimp, speedThrust, modifyDamageBySpeed , speedScale, speedAdd, speedNegate , ticksPerMeter, speedFromWeight, rangeFromSpeedAndLinger #ifdef EXPOSE_INTERNAL -- * Internal operations , _timeTick, turnsInSecond, sInMs, minimalSpeed, rangeFromSpeed #endif ) where import Prelude () import Game.LambdaHack.Common.Prelude import Data.Binary import qualified Data.Char as Char import Data.Int (Int64) -- | Game time in ticks. The time dimension. -- One tick is 1 microsecond (one millionth of a second), -- one turn is 0.5 s. newtype Time = Time {timeTicks :: Int64} deriving (Show, Eq, Ord, Enum, Bounded, Binary) -- | Start of the game time, or zero lenght time interval. timeZero :: Time timeZero = Time 0 -- | The smallest unit of time. Should not be exported and used elsewhere, -- because the proportion of turn to tick is an implementation detail. -- The significance of this detail is only that it determines resolution -- of the time dimension. _timeTick :: Time _timeTick = Time 1 -- | An infinitesimal time period. timeEpsilon :: Time timeEpsilon = _timeTick -- | At least once per clip all moves are resolved -- and a frame or a frame delay is generated. -- Currently one clip is 0.05 s, but it may change, -- and the code should not depend on this fixed value. timeClip :: Time timeClip = Time 50000 -- | One turn is 0.5 s. The code may depend on that. -- Actors at normal speed (2 m/s) take one turn to move one tile (1 m by 1 m). timeTurn :: Time timeTurn = Time 500000 -- | This many turns fit in a single second. turnsInSecond :: Int64 turnsInSecond = 2 -- | This many ticks fits in a single second. Do not export, timeSecond :: Time timeSecond = Time $ timeTicks timeTurn * turnsInSecond -- | Absolute time addition, e.g., for summing the total game session time -- from the times of individual games. absoluteTimeAdd :: Time -> Time -> Time {-# INLINE absoluteTimeAdd #-} absoluteTimeAdd (Time t1) (Time t2) = Time (t1 + t2) absoluteTimeSubtract :: Time -> Time -> Time {-# INLINE absoluteTimeSubtract #-} absoluteTimeSubtract (Time t1) (Time t2) = Time (t1 - t2) -- | Absolute time negation. To be used for reversing time flow, -- e.g., for comparing absolute times in the reverse order. absoluteTimeNegate :: Time -> Time {-# INLINE absoluteTimeNegate #-} absoluteTimeNegate (Time t) = Time (-t) -- | How many time intervals of the latter kind fits in an interval -- of the former kind. timeFit :: Time -> Time -> Int {-# INLINE timeFit #-} timeFit (Time t1) (Time t2) = fromEnum $ t1 `div` t2 -- | How many time intervals of the latter kind cover an interval -- of the former kind (rounded up). timeFitUp :: Time -> Time -> Int {-# INLINE timeFitUp #-} timeFitUp (Time t1) (Time t2) = fromEnum $ t1 `divUp` t2 -- | 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) -- | Shifting an absolute time by a time vector. timeShift :: Time -> Delta Time -> Time {-# INLINE timeShift #-} timeShift (Time t1) (Delta (Time t2)) = Time (t1 + t2) -- | Time time vector between the second and the first absolute times. -- The arguments are in the same order as in the underlying scalar subtraction. timeDeltaToFrom :: Time -> Time -> Delta Time {-# INLINE timeDeltaToFrom #-} timeDeltaToFrom (Time t1) (Time t2) = Delta $ Time (t1 - t2) -- | Addition of time deltas. timeDeltaAdd :: Delta Time -> Delta Time -> Delta Time {-# INLINE timeDeltaAdd #-} timeDeltaAdd (Delta (Time t1)) (Delta (Time t2)) = Delta $ Time (t1 - t2) -- | Subtraction of time deltas. -- The arguments are in the same order as in the underlying scalar subtraction. timeDeltaSubtract :: Delta Time -> Delta Time -> Delta Time {-# INLINE timeDeltaSubtract #-} timeDeltaSubtract (Delta (Time t1)) (Delta (Time t2)) = Delta $ Time (t1 - t2) -- | Reverse a time vector. timeDeltaReverse :: Delta Time -> Delta Time {-# INLINE timeDeltaReverse #-} timeDeltaReverse (Delta (Time t)) = Delta (Time (-t)) -- | Scale the time vector by an @Int@ scalar value. timeDeltaScale :: Delta Time -> Int -> Delta Time {-# INLINE timeDeltaScale #-} timeDeltaScale (Delta (Time t)) s = Delta (Time (t * fromIntegral s)) -- | Take the given percent of the time vector. timeDeltaPercent :: Delta Time -> Int -> Delta Time {-# INLINE timeDeltaPercent #-} timeDeltaPercent (Delta (Time t)) s = Delta (Time (t * fromIntegral s `div` 100)) -- | Divide a time vector. timeDeltaDiv :: Delta Time -> Int -> Delta Time {-# INLINE timeDeltaDiv #-} 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 {-# INLINE timeDeltaToDigit #-} timeDeltaToDigit (Delta (Time maxT)) (Delta (Time t)) = let k = 1 + 9 * t `div` maxT digit | k > 9 = '*' | k < 1 = '-' | otherwise = Char.intToDigit $ fromEnum 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 {-# INLINE toSpeed #-} toSpeed s = Speed $ fromIntegral s * sInMs `div` 10 -- | Pretty-printing of speed in the format used in content definitions. fromSpeed :: Speed -> Int {-# INLINE fromSpeed #-} fromSpeed (Speed s) = fromEnum $ s * 10 `div` sInMs minSpeed :: Int minSpeed = 5 -- | The minimal speed is half a meter (half a step across a tile) -- per second (two standard turns, which the time span during which -- projectile moves, unless it has modified linger value). -- This is four times slower than standard human movement speed. -- -- It needen't be lower, because @rangeFromSpeed@ gives 0 steps -- with such speed, so the actor's trajectory is empty, so it drops down -- at once. Twice that speed already moves a normal projectile one step -- before it stops. It shouldn't be lower or a slow actor would incur -- such a time debt for performing a single action that he'd be paralyzed -- for many turns, e.g., leaving his dead body on the screen for very long. minimalSpeed :: Int64 minimalSpeed = let Speed msp = toSpeed minSpeed in assert (msp == sInMs `div` 2) msp -- | No movement possible at that speed. speedZero :: Speed speedZero = Speed 0 -- | Fast walk speed (2 m/s) that suffices to move one tile in one turn. speedWalk :: Speed speedWalk = Speed $ 2 * sInMs -- | Limp speed (1 m/s) that suffices to move one tile in two turns. -- This is the minimal speed for projectiles to fly just one space and drop. speedLimp :: Speed speedLimp = Speed sInMs -- | Sword thrust speed (10 m/s). Base weapon damages, both melee and ranged, -- are given assuming this speed and ranged damage is modified -- accordingly when projectile speeds differ. Differences in melee -- weapon swing speeds are captured in damage bonuses instead, -- since many other factors influence total damage. -- -- Billiard ball is 25 m/s, sword swing at the tip is 35 m/s, -- medieval bow is 70 m/s, AK47 is 700 m/s. speedThrust :: Speed speedThrust = Speed $ 10 * sInMs -- | Modify damage when projectiles is at a non-standard speed. -- Energy and so damage is proportional to the square of speed, -- hence the formula. modifyDamageBySpeed :: Int64 -> Speed -> Int64 modifyDamageBySpeed dmg (Speed s) = let Speed sThrust = speedThrust in round (fromIntegral dmg * fromIntegral s ^ (2 :: Int) -- overflows Int64 / fromIntegral sThrust ^ (2 :: Int) :: Double) -- | Scale speed by an @Int@ scalar value. speedScale :: Rational -> Speed -> Speed {-# INLINE speedScale #-} speedScale s (Speed v) = Speed (round $ fromIntegral v * s) -- | Speed addition. speedAdd :: Speed -> Speed -> Speed {-# INLINE speedAdd #-} speedAdd (Speed s1) (Speed s2) = Speed (s1 + s2) -- | Speed negation. speedNegate :: Speed -> Speed {-# INLINE speedNegate #-} speedNegate (Speed n) = Speed (-n) -- | The number of time ticks it takes to walk 1 meter at the given speed. ticksPerMeter :: Speed -> Delta Time {-# INLINE ticksPerMeter #-} ticksPerMeter (Speed v) = -- Prevent division by zero or infinite time taken for any action. Delta $ Time $ timeTicks timeSecond * sInMs `divUp` max minimalSpeed v -- | Calculate projectile speed from item weight in grams -- and velocity percent modifier. -- See . speedFromWeight :: Int -> Int -> Speed speedFromWeight !weight !throwVelocity = let w = fromIntegral weight mpMs | w < 250 = sInMs * 20 | w < 1500 = sInMs * 20 * 1250 `div` (w + 1000) | w < 10500 = sInMs * (11000 - w) `div` 1000 | otherwise = minimalSpeed * 2 -- move one step and drop v = mpMs * fromIntegral throwVelocity `div` 100 -- We round down to the nearest multiple of 2M (unless the speed -- is very low), to ensure both turns of flight cover the same distance -- and that the speed matches the distance traveled exactly. multiple2M = if v > 2 * sInMs then 2 * sInMs * (v `div` (2 * sInMs)) else v in Speed $ max minimalSpeed multiple2M -- | Calculate maximum range in meters of a projectile from its speed. -- See . -- With this formula, each projectile flies for at most 1 second, -- that is 2 standard turns, and then drops to the ground. rangeFromSpeed :: Speed -> Int {-# INLINE rangeFromSpeed #-} rangeFromSpeed (Speed v) = fromEnum $ v `div` sInMs -- | Calculate maximum range taking into account the linger percentage. rangeFromSpeedAndLinger :: Speed -> Int -> Int rangeFromSpeedAndLinger !speed !throwLinger = let range = rangeFromSpeed speed in throwLinger * range `divUp` 100 LambdaHack-0.8.3.0/Game/LambdaHack/Common/Thread.hs0000644000000000000000000000142313315545734017642 0ustar0000000000000000-- | Keeping track of forked threads. module Game.LambdaHack.Common.Thread ( forkChild, waitForChildren ) where import Prelude () import Game.LambdaHack.Common.Prelude import Control.Concurrent.Async import Control.Concurrent.MVar -- Swiped from -- 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.8.3.0/Game/LambdaHack/Common/HighScore.hs0000644000000000000000000002067313315545734020316 0ustar0000000000000000{-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving #-} -- | High score table operations. module Game.LambdaHack.Common.HighScore ( ScoreTable, ScoreDict , empty, register, showScore, getTable, getRecord, highSlideshow #ifdef EXPOSE_INTERNAL -- * Internal operations , ScoreRecord, insertPos, showTable, showNearbyScores #endif ) where import Prelude () import Game.LambdaHack.Common.Prelude import Data.Binary import qualified Data.EnumMap.Strict as EM import qualified Data.Text as T import Data.Time.Clock.POSIX import Data.Time.LocalTime import GHC.Generics (Generic) import qualified NLP.Miniutter.English as MU import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.Kind import Game.LambdaHack.Common.Misc 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 :: POSIXTime -- ^ date of the last game interruption , status :: Status -- ^ reason of the game interruption , challenge :: Challenge -- ^ challenge setup of the game , gplayerName :: Text -- ^ name of the faction's gplayer , ourVictims :: EM.EnumMap (ContentId ItemKind) Int -- ^ allies lost , theirVictims :: EM.EnumMap (ContentId ItemKind) Int -- ^ foes killed } deriving (Show, Eq, Ord, Generic) 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 (ContentId ModeKind) ScoreTable -- | Empty score table empty :: ScoreDict empty = EM.empty -- | Insert a new score into the table, Return new table and the ranking. -- Make sure the table doesn't grow too large. insertPos :: ScoreRecord -> ScoreTable -> (ScoreTable, Int) insertPos s (ScoreTable table) = let (prefix, suffix) = span (> s) table pos = length prefix + 1 in (ScoreTable $ prefix ++ [s] ++ take (100 - pos) suffix, pos) -- | Register a new score in a score table. register :: ScoreTable -- ^ old table -> Int -- ^ the total value of faction items -> Int -- ^ the total value of dungeon items -> Time -- ^ game time spent -> Status -- ^ reason of the game interruption -> POSIXTime -- ^ current date -> Challenge -- ^ challenge setup -> Text -- ^ name of the faction's gplayer -> EM.EnumMap (ContentId ItemKind) Int -- ^ allies lost -> EM.EnumMap (ContentId ItemKind) Int -- ^ foes killed -> HiCondPoly -> (Bool, (ScoreTable, Int)) register table total dungeonTotal time status@Status{stOutcome} date challenge gplayerName ourVictims theirVictims hiCondPoly = let turnsSpent = fromIntegral $ timeFitUp time timeTurn hiInValue (hi, c) = assert (total <= dungeonTotal) $ case hi of HiConst -> c HiLoot | dungeonTotal == 0 -> c -- a fluke; no gold generated HiLoot -> c * fromIntegral total / fromIntegral dungeonTotal 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 -- Other challenges than HP difficulty are not reflected in score. points = (ceiling :: Double -> Int) $ hiCondValue hiCondPoly * 1.5 ^^ (- (difficultyCoeff (cdiff challenge))) negTime = absoluteTimeNegate time score = ScoreRecord{..} in (points > 0, insertPos score table) -- | Show a single high score, from the given ranking in the high score table. showScore :: TimeZone -> (Int, ScoreRecord) -> [Text] showScore tz (pos, score) = let Status{stOutcome, stDepth} = status score died = case stOutcome of Killed -> "perished on level" <+> tshow (abs stDepth) Defeated -> "got defeated" Camping -> "set camp" Conquer -> "slew all opposition" Escape -> "emerged victorious" Restart -> "resigned prematurely" curDate = T.take 19 . tshow . utcToLocalTime tz . posixSecondsToUTCTime . date $ score turns = absoluteTimeNegate (negTime score) `timeFitUp` timeTurn tpos = T.justifyRight 3 ' ' $ tshow pos tscore = T.justifyRight 6 ' ' $ tshow $ points score victims = let nkilled = sum $ EM.elems $ theirVictims score nlost = sum $ EM.elems $ ourVictims score in "killed" <+> tshow nkilled <> ", lost" <+> tshow nlost diff = cdiff $ challenge 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 :: ContentId ModeKind -> ScoreDict -> ScoreTable getTable = EM.findWithDefault (ScoreTable []) getRecord :: Int -> ScoreTable -> ScoreRecord getRecord pos (ScoreTable table) = fromMaybe (error $ "" `showFailure` (pos, table)) $ listToMaybe $ drop (pred pos) table -- | Show a screenful of the high scores table. -- Parameter height is the number of (3-line) scores to be shown. showTable :: TimeZone -> ScoreTable -> Int -> Int -> [Text] showTable tz (ScoreTable table) start height = let zipped = zip [1..] table screenful = take height . drop (start - 1) $ zipped in "" : intercalate [""] (map (showScore tz) screenful) -- | Produce a couple of renderings of the high scores table. showNearbyScores :: TimeZone -> Int -> ScoreTable -> Int -> [[Text]] showNearbyScores tz pos h height = if pos <= height then [showTable tz h 1 height] else [showTable tz h 1 height, showTable tz 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 -> TimeZone -- ^ the timezone where the game is run -> (Text, [[Text]]) highSlideshow table pos gameModeName tz = let (_, nlines) = normalLevelBound 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 -> -- This is only according to the limited player knowledge; -- the final score can be different, which is fine: ("your valiant exploits", MU.PlEtc, "") Conquer -> ("your ruthless victory", MU.Sg3rd, if pos <= height 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.Text gameModeName] msg = makeSentence [ MU.SubjectVerb person MU.Yes (MU.Text subject) "award you" , MU.Ordinal pos, "place", msgUnless ] in (msg, showNearbyScores tz pos table height) LambdaHack-0.8.3.0/Game/LambdaHack/Common/Faction.hs0000644000000000000000000001673013315545734020025 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} -- | Factions taking part in the game, e.g., a hero faction, a monster faction -- and an animal faction. module Game.LambdaHack.Common.Faction ( FactionId, FactionDict, Faction(..), Diplomacy(..), Status(..) , Target(..), TGoal(..), Challenge(..) , gleader, tgtKindDescription, isHorrorFact , noRunWithMulti, isAIFact, autoDungeonLevel, automatePlayer , isFoe, isFriend , difficultyBound, difficultyDefault, difficultyCoeff, difficultyInverse , defaultChallenge #ifdef EXPOSE_INTERNAL -- * Internal operations , Dipl #endif ) where import Prelude () import Game.LambdaHack.Common.Prelude import Data.Binary import qualified Data.EnumMap.Strict as EM import qualified Data.IntMap.Strict as IM import GHC.Generics (Generic) 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 Game.LambdaHack.Common.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 -- | The faction datatype. data Faction = Faction { gname :: Text -- ^ individual name , gcolor :: Color.Color -- ^ color of actors or their frames , gplayer :: Player -- ^ the player spec for this faction , ginitial :: [(Int, Int, GroupName ItemKind)] -- ^ initial actors , gdipl :: Dipl -- ^ diplomatic mode , gquit :: Maybe Status -- ^ cause of game end/exit , _gleader :: Maybe ActorId -- ^ the leader of the faction; don't use -- in place of sleader on clients , gsha :: ItemBag -- ^ faction's shared inventory , gvictims :: EM.EnumMap (ContentId ItemKind) Int -- ^ members killed , gvictimsD :: EM.EnumMap (ContentId ModeKind) (IM.IntMap (EM.EnumMap (ContentId ItemKind) Int)) -- ^ members killed in the past, by game mode and difficulty level } deriving (Show, Eq, Generic) instance Binary Faction -- | Diplomacy states. Higher overwrite lower in case of asymmetric content. data Diplomacy = Unknown | Neutral | Alliance | War deriving (Show, Eq, Ord, Enum, Generic) instance Binary Diplomacy type Dipl = EM.EnumMap FactionId Diplomacy -- | Current game status. data Status = Status { stOutcome :: Outcome -- ^ current game outcome , stDepth :: Int -- ^ depth of the final encounter , stNewGame :: Maybe (GroupName ModeKind) -- ^ new game group to start, if any } deriving (Show, Eq, Ord, Generic) instance Binary Status -- | The type of na actor target. data Target = TEnemy ActorId Bool -- ^ target an actor; cycle only trough seen foes, unless the flag is set | TPoint TGoal LevelId Point -- ^ target a concrete spot | TVector Vector -- ^ target position relative to actor deriving (Show, Eq, Ord, Generic) instance Binary Target -- | The goal of an actor. data TGoal = TEnemyPos ActorId Bool -- ^ last seen position of the targeted actor | TEmbed ItemBag Point -- ^ embedded item that can be triggered; -- in @TPoint (TEmbed bag p) _ q@ usually @bag@ is embbedded in @p@ -- and @q@ is an adjacent open tile | TItem ItemBag -- ^ item lying on the ground | TSmell -- ^ smell potentially left by enemies | TUnknown -- ^ an unknown tile to be explored | TKnown -- ^ a known tile to be patrolled | TAny -- ^ an unspecified goal deriving (Show, Eq, Ord, Generic) instance Binary TGoal data Challenge = Challenge { cdiff :: Int -- ^ game difficulty level (HP bonus or malus) , cwolf :: Bool -- ^ lone wolf challenge (only one starting character) , cfish :: Bool -- ^ cold fish challenge (no healing from enemies) } deriving (Show, Eq, Ord, Generic) instance Binary Challenge gleader :: Faction -> Maybe ActorId gleader = _gleader tgtKindDescription :: Target -> Text tgtKindDescription tgt = case tgt of TEnemy _ True -> "at actor" TEnemy _ False -> "at enemy" TPoint{} -> "at position" TVector{} -> "with a vector" -- | Tell whether the faction consists of summoned horrors only. -- -- Horror player is special, for summoned actors that don't belong to any -- of the main players of a given game. E.g., animals summoned during -- a skirmish game between two hero factions land in the horror faction. -- In every game, either all factions for which summoning items exist -- should be present or a horror player should be added to host them. isHorrorFact :: Faction -> Bool isHorrorFact fact = nameOfHorrorFact `elem` fgroups (gplayer fact) -- 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 -> Player 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. isFoe :: FactionId -> Faction -> FactionId -> Bool isFoe fid1 fact1 fid2 = fid1 /= fid2 -- shortcut && War == EM.findWithDefault Unknown fid2 (gdipl fact1) -- | Check if factions are allied. Assumes symmetry. isAlly :: Faction -> FactionId -> Bool {-# INLINE isAlly #-} isAlly fact1 fid2 = Alliance == EM.findWithDefault Unknown fid2 (gdipl fact1) -- | Check if factions are allied or are the same faction. Assumes symmetry. isFriend :: FactionId -> Faction -> FactionId -> Bool isFriend fid1 fact1 fid2 = fid1 == fid2 || isAlly fact1 fid2 difficultyBound :: Int difficultyBound = 9 difficultyDefault :: Int difficultyDefault = (1 + difficultyBound) `div` 2 -- The function is its own inverse. difficultyCoeff :: Int -> Int difficultyCoeff n = difficultyDefault - n -- The function is its own inverse. difficultyInverse :: Int -> Int difficultyInverse n = difficultyBound + 1 - n defaultChallenge :: Challenge defaultChallenge = Challenge { cdiff = difficultyDefault , cwolf = False , cfish = False } LambdaHack-0.8.3.0/Game/LambdaHack/Common/Ability.hs0000644000000000000000000000507113315545734020033 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} -- | AI strategy abilities. module Game.LambdaHack.Common.Ability ( Ability(..), Skills , zeroSkills, unitSkills, addSkills, scaleSkills, tacticSkills , blockOnly, meleeAdjacent, meleeAndRanged, ignoreItems ) where import Prelude () import Game.LambdaHack.Common.Prelude import Control.DeepSeq import Data.Binary import qualified Data.EnumMap.Strict as EM import Data.Hashable (Hashable) import GHC.Generics (Generic) import Game.LambdaHack.Common.Misc -- | Actor and faction abilities corresponding to client-server requests. data Ability = AbMove | AbMelee | AbDisplace | AbAlter | AbWait | AbMoveItem | AbProject | AbApply deriving (Eq, Ord, Generic, Enum, Bounded) -- | Skill level in particular abilities. -- -- This representation is sparse, so better than a record when there are more -- item kinds (with few abilities) than actors (with many abilities), -- especially if the number of abilities grows as the engine is developed. -- It's also easier to code and maintain. 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 *) tacticSkills :: Tactic -> Skills tacticSkills TExplore = zeroSkills tacticSkills TFollow = zeroSkills tacticSkills TFollowNoItems = ignoreItems tacticSkills TMeleeAndRanged = meleeAndRanged tacticSkills TMeleeAdjacent = meleeAdjacent tacticSkills TBlock = blockOnly tacticSkills TRoam = zeroSkills tacticSkills TPatrol = zeroSkills minusTen, blockOnly, meleeAdjacent, meleeAndRanged, ignoreItems :: Skills -- To make sure only a lot of weak items can override move-only-leader, etc. minusTen = EM.fromDistinctAscList $ zip [minBound..maxBound] (repeat (-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] (repeat (-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" instance NFData Ability instance Binary Ability where put = putWord8 . toEnum . fromEnum get = fmap (toEnum . fromEnum) getWord8 instance Hashable Ability LambdaHack-0.8.3.0/Game/LambdaHack/Common/Tile.hs0000644000000000000000000003121613315545734017333 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} -- | 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 ( -- * Construction of tile property lookup speedup tables speedupTile -- * Sped up property lookups , isClear, isLit, isWalkable, isDoor, isChangable , isSuspect, isHideAs, consideredByAI, isExplorable , isOftenItem, isOftenActor, isNoItem, isNoActor, isEasyOpen , alterMinSkill, alterMinWalk -- * Slow property lookups , kindHasFeature, hasFeature, openTo, closeTo, embeddedItems, revealAs , obscureAs, hideAs, buildAs, isEasyOpenKind, isOpenable, isClosable #ifdef EXPOSE_INTERNAL -- * Internal operations , createTab, createTabWithKey, accessTab, alterMinSkillKind, alterMinWalkKind #endif ) where import Prelude () import Game.LambdaHack.Common.Prelude import qualified Data.Vector.Unboxed as U import Data.Word (Word8) import Game.LambdaHack.Common.ContentData import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.Random import Game.LambdaHack.Content.ItemKind (ItemKind) import Game.LambdaHack.Content.TileKind (TileKind, TileSpeedup (..), isUknownSpace) import qualified Game.LambdaHack.Content.TileKind as TK createTab :: U.Unbox a => ContentData TileKind -> (TileKind -> a) -> TK.Tab a createTab cotile prop = TK.Tab $ U.convert $ omapVector cotile prop createTabWithKey :: U.Unbox a => ContentData TileKind -> (ContentId TileKind -> TileKind -> a) -> TK.Tab a createTabWithKey cotile prop = TK.Tab $ U.convert $ oimapVector cotile prop -- Unsafe indexing is pretty safe here, because we guard the vector -- with the newtype. accessTab :: U.Unbox a => TK.Tab a -> ContentId TileKind -> a {-# INLINE accessTab #-} accessTab (TK.Tab tab) ki = tab `U.unsafeIndex` contentIdIndex ki speedupTile :: Bool -> ContentData TileKind -> TileSpeedup speedupTile allClear cotile = -- Vectors pack bools as Word8 by default. No idea if the extra memory -- taken makes random lookups more or less efficient, so not optimizing -- further, until I have benchmarks. let isClearTab | allClear = createTab cotile $ not . (== maxBound) . TK.talter | otherwise = createTab cotile $ kindHasFeature TK.Clear isLitTab = createTab cotile $ not . kindHasFeature TK.Dark isWalkableTab = createTab cotile $ kindHasFeature TK.Walkable isDoorTab = createTab cotile $ \tk -> let getTo TK.OpenTo{} = True getTo TK.CloseTo{} = True getTo _ = False in any getTo $ TK.tfeature tk isChangableTab = createTab cotile $ \tk -> let getTo TK.ChangeTo{} = True getTo _ = False in any getTo $ TK.tfeature tk isSuspectTab = createTab cotile TK.isSuspectKind isHideAsTab = createTab cotile $ \tk -> let getTo TK.HideAs{} = True getTo _ = False in any getTo $ TK.tfeature tk consideredByAITab = createTab cotile $ kindHasFeature TK.ConsideredByAI isOftenItemTab = createTab cotile $ kindHasFeature TK.OftenItem isOftenActorTab = createTab cotile $ kindHasFeature TK.OftenActor isNoItemTab = createTab cotile $ kindHasFeature TK.NoItem isNoActorTab = createTab cotile $ kindHasFeature TK.NoActor isEasyOpenTab = createTab cotile isEasyOpenKind alterMinSkillTab = createTabWithKey cotile alterMinSkillKind alterMinWalkTab = createTabWithKey cotile alterMinWalkKind in TileSpeedup {..} -- Check that alter can be used, if not, @maxBound@. -- For now, we assume only items with @Embed@ may have embedded items, -- whether inserted at dungeon creation or later on. -- This is used by UI and server to validate (sensibility of) altering. -- See the comment for @alterMinWalkKind@ regarding @HideAs@. alterMinSkillKind :: ContentId TileKind -> TileKind -> Word8 alterMinSkillKind _k tk = let getTo TK.OpenTo{} = True getTo TK.CloseTo{} = True getTo TK.ChangeTo{} = True getTo TK.HideAs{} = True -- in case tile swapped, but server sends hidden getTo TK.RevealAs{} = True getTo TK.ObscureAs{} = True getTo TK.Embed{} = True getTo TK.ConsideredByAI = True getTo _ = False in if any getTo $ TK.tfeature tk then TK.talter tk else maxBound -- How high alter skill is needed to make it walkable. If already -- walkable, put @0@, if can't, put @maxBound@. Used only be AI and Bfs -- We don't include @HideAs@, because it's very unlikely anybody swapped -- the tile while AI was not looking so AI can assume it's still uninteresting. -- Pathfinding in UI will also not show such tile as passable, which is OK. -- If a human player has a suspicion the tile was swapped, he can check -- it manually, disregarding the displayed path hints. alterMinWalkKind :: ContentId TileKind -> TileKind -> Word8 alterMinWalkKind k tk = let getTo TK.OpenTo{} = True getTo TK.RevealAs{} = True getTo TK.ObscureAs{} = True getTo _ = False in if | kindHasFeature TK.Walkable tk -> 0 | isUknownSpace k -> TK.talter tk | any getTo $ TK.tfeature tk -> TK.talter tk | otherwise -> maxBound -- | Whether a tile does not block vision. -- Essential for efficiency of "FOV", hence tabulated. isClear :: TileSpeedup -> ContentId TileKind -> Bool {-# INLINE isClear #-} isClear TileSpeedup{isClearTab} = accessTab isClearTab -- | Whether a tile has ambient light --- is lit on its own. -- Essential for efficiency of "Perception", hence tabulated. isLit :: TileSpeedup -> ContentId TileKind -> Bool {-# INLINE isLit #-} isLit TileSpeedup{isLitTab} = accessTab isLitTab -- | Whether actors can walk into a tile. -- Essential for efficiency of pathfinding, hence tabulated. isWalkable :: TileSpeedup -> ContentId TileKind -> Bool {-# INLINE isWalkable #-} isWalkable TileSpeedup{isWalkableTab} = accessTab isWalkableTab -- | Whether a tile is a door, open or closed. -- Essential for efficiency of pathfinding, hence tabulated. isDoor :: TileSpeedup -> ContentId TileKind -> Bool {-# INLINE isDoor #-} isDoor TileSpeedup{isDoorTab} = accessTab isDoorTab -- | Whether a tile is changable. isChangable :: TileSpeedup -> ContentId TileKind -> Bool {-# INLINE isChangable #-} isChangable TileSpeedup{isChangableTab} = accessTab isChangableTab -- | Whether a tile is suspect. -- Essential for efficiency of pathfinding, hence tabulated. isSuspect :: TileSpeedup -> ContentId TileKind -> Bool {-# INLINE isSuspect #-} isSuspect TileSpeedup{isSuspectTab} = accessTab isSuspectTab isHideAs :: TileSpeedup -> ContentId TileKind -> Bool {-# INLINE isHideAs #-} isHideAs TileSpeedup{isHideAsTab} = accessTab isHideAsTab consideredByAI :: TileSpeedup -> ContentId TileKind -> Bool {-# INLINE consideredByAI #-} consideredByAI TileSpeedup{consideredByAITab} = accessTab consideredByAITab -- | Whether one can easily explore a tile, possibly finding a treasure, -- either spawned there or dropped there by a (dying from poison) foe. -- Doors can't be explorable since revealing a secret tile -- should not change it's (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. -- Still, a foe that digs through a wall will affect our exploration counter -- and if content lets walls contain threasure, such backtraking makes sense. isExplorable :: TileSpeedup -> ContentId TileKind -> Bool isExplorable coTileSpeedup t = isWalkable coTileSpeedup t && not (isDoor coTileSpeedup t) isOftenItem :: TileSpeedup -> ContentId TileKind -> Bool {-# INLINE isOftenItem #-} isOftenItem TileSpeedup{isOftenItemTab} = accessTab isOftenItemTab isOftenActor :: TileSpeedup -> ContentId TileKind -> Bool {-# INLINE isOftenActor #-} isOftenActor TileSpeedup{isOftenActorTab} = accessTab isOftenActorTab isNoItem :: TileSpeedup -> ContentId TileKind -> Bool {-# INLINE isNoItem #-} isNoItem TileSpeedup{isNoItemTab} = accessTab isNoItemTab isNoActor :: TileSpeedup -> ContentId TileKind -> Bool {-# INLINE isNoActor #-} isNoActor TileSpeedup{isNoActorTab} = accessTab isNoActorTab -- | Whether a tile kind (specified by its id) has an OpenTo feature -- and reasonable alter min skill. isEasyOpen :: TileSpeedup -> ContentId TileKind -> Bool {-# INLINE isEasyOpen #-} isEasyOpen TileSpeedup{isEasyOpenTab} = accessTab isEasyOpenTab alterMinSkill :: TileSpeedup -> ContentId TileKind -> Int {-# INLINE alterMinSkill #-} alterMinSkill TileSpeedup{alterMinSkillTab} = fromEnum . accessTab alterMinSkillTab alterMinWalk :: TileSpeedup -> ContentId TileKind -> Int {-# INLINE alterMinWalk #-} alterMinWalk TileSpeedup{alterMinWalkTab} = fromEnum . accessTab alterMinWalkTab -- | Whether a tile kind has the given feature. kindHasFeature :: TK.Feature -> TileKind -> Bool {-# INLINE kindHasFeature #-} kindHasFeature f t = f `elem` TK.tfeature t -- | Whether a tile kind (specified by its id) has the given feature. hasFeature :: ContentData TileKind -> TK.Feature -> ContentId TileKind -> Bool {-# INLINE hasFeature #-} hasFeature cotile f t = kindHasFeature f (okind cotile t) openTo :: ContentData TileKind -> ContentId TileKind -> Rnd (ContentId TileKind) openTo cotile t = do let getTo (TK.OpenTo grp) acc = grp : acc getTo _ acc = acc case foldr getTo [] $ TK.tfeature $ okind cotile t of [grp] -> fromMaybe (error $ "" `showFailure` grp) <$> opick cotile grp (const True) _ -> return t closeTo :: ContentData TileKind -> ContentId TileKind -> Rnd (ContentId TileKind) closeTo cotile t = do let getTo (TK.CloseTo grp) acc = grp : acc getTo _ acc = acc case foldr getTo [] $ TK.tfeature $ okind cotile t of [grp] -> fromMaybe (error $ "" `showFailure` grp) <$> opick cotile grp (const True) _ -> return t embeddedItems :: ContentData TileKind -> ContentId TileKind -> [GroupName ItemKind] embeddedItems cotile t = let getTo (TK.Embed igrp) acc = igrp : acc getTo _ acc = acc in foldr getTo [] $ TK.tfeature $ okind cotile t revealAs :: ContentData TileKind -> ContentId TileKind -> Rnd (ContentId TileKind) revealAs cotile t = do let getTo (TK.RevealAs grp) acc = grp : acc getTo _ acc = acc case foldr getTo [] $ TK.tfeature $ okind cotile t of [] -> return t groups -> do grp <- oneOf groups fromMaybe (error $ "" `showFailure` grp) <$> opick cotile grp (const True) obscureAs :: ContentData TileKind -> ContentId TileKind -> Rnd (ContentId TileKind) obscureAs cotile t = do let getTo (TK.ObscureAs grp) acc = grp : acc getTo _ acc = acc case foldr getTo [] $ TK.tfeature $ okind cotile t of [] -> return t groups -> do grp <- oneOf groups fromMaybe (error $ "" `showFailure` grp) <$> opick cotile grp (const True) hideAs :: ContentData TileKind -> ContentId TileKind -> Maybe (ContentId TileKind) hideAs cotile t = let getTo TK.HideAs{} = True getTo _ = False in case find getTo $ TK.tfeature $ okind cotile t of Just (TK.HideAs grp) -> let tHidden = ouniqGroup cotile grp in assert (tHidden /= t) $ Just tHidden _ -> Nothing buildAs :: ContentData TileKind -> ContentId TileKind -> ContentId TileKind buildAs cotile t = let getTo TK.BuildAs{} = True getTo _ = False in case find getTo $ TK.tfeature $ okind cotile t of Just (TK.BuildAs grp) -> ouniqGroup cotile grp _ -> t isEasyOpenKind :: TileKind -> Bool isEasyOpenKind tk = let getTo TK.OpenTo{} = True getTo TK.Walkable = True -- very easy open getTo _ = False in TK.talter tk < 10 && any getTo (TK.tfeature tk) -- | Whether a tile kind (specified by its id) has an OpenTo feature. isOpenable :: ContentData TileKind -> ContentId TileKind -> Bool isOpenable cotile t = TK.isOpenableKind $ okind cotile t -- | Whether a tile kind (specified by its id) has a CloseTo feature. isClosable :: ContentData TileKind -> ContentId TileKind -> Bool isClosable cotile t = TK.isClosableKind $ okind cotile t LambdaHack-0.8.3.0/Game/LambdaHack/Common/Random.hs0000644000000000000000000000741413315545734017661 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 -- * Specialized monadic folds , foldrM, foldlM' #ifdef EXPOSE_INTERNAL -- * Internal operations , rollFreq #endif ) where import Prelude () import Game.LambdaHack.Common.Prelude import qualified Control.Monad.Trans.State.Strict as St import Data.Ratio import qualified System.Random as R import qualified Game.LambdaHack.Common.Dice as Dice import Game.LambdaHack.Common.Frequency -- | The monad of computations with random generator state. 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 {-# INLINE randomR #-} randomR = St.state . R.randomR -- | Get a random object of a given type with a uniform distribution. random :: (R.Random a) => Rnd a {-# INLINE random #-} random = St.state R.random -- | Get any element of a list with equal probability. oneOf :: [a] -> Rnd a oneOf [] = error $ "oneOf []" `showFailure` () oneOf [x] = return x oneOf xs = do r <- randomR (0, length xs - 1) return $! xs !! r -- | Gen an element according to a frequency distribution. frequency :: Show a => Frequency a -> Rnd a {-# INLINE frequency #-} frequency = St.state . rollFreq -- | Randomly choose an item according to the distribution. rollFreq :: Show a => Frequency a -> R.StdGen -> (a, R.StdGen) rollFreq fr g = case runFrequency fr of [] -> error $ "choice from an empty frequency" `showFailure` nameFrequency fr [(n, x)] | n <= 0 -> error $ "singleton void frequency" `showFailure` (nameFrequency fr, n, x) [(_, x)] -> (x, g) -- speedup fs -> let sumf = foldl' (\ !acc (!n, _) -> acc + n) 0 fs (r, ng) = R.randomR (1, sumf) g frec :: Int -> [(Int, a)] -> a frec !m [] = error $ "impossible roll" `showFailure` (nameFrequency fr, fs, m) frec m ((n, x) : _) | m <= n = x frec m ((n, _) : xs) = frec (m - n) xs in assert (sumf > 0 `blame` "frequency with nothing to pick" `swith` (nameFrequency fr, fs)) (frec r fs, ng) -- | Fractional chance. type Chance = Rational -- | Give @True@, with probability determined by the fraction. chance :: Chance -> Rnd Bool chance r = do let n = numerator r d = denominator r k <- randomR (1, d) return (k <= n) -- | Cast dice scaled with current level depth. -- Note that at the first level, the scaled dice are always ignored. castDice :: Dice.AbsDepth -> Dice.AbsDepth -> Dice.Dice -> Rnd Int castDice = Dice.castDice randomR -- | Cast dice scaled with current level depth and return @True@ -- if the results is greater than 50. chanceDice :: Dice.AbsDepth -> Dice.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 :: Dice.AbsDepth -> Dice.AbsDepth -> Dice.DiceXY -> Rnd (Int, Int) castDiceXY ldepth totalDepth (Dice.DiceXY dx dy) = do x <- castDice ldepth totalDepth dx y <- castDice ldepth totalDepth dy return (x, y) foldrM :: Foldable t => (a -> b -> Rnd b) -> b -> t a -> Rnd b foldrM f z0 xs = let f' x (z, g) = St.runState (f x z) g in St.state $ \g -> foldr f' (z0, g) xs foldlM' :: Foldable t => (b -> a -> Rnd b) -> b -> t a -> Rnd b foldlM' f z0 xs = let f' (z, g) x = St.runState (f z x) g in St.state $ \g -> foldl' f' (z0, g) xs LambdaHack-0.8.3.0/Game/LambdaHack/Common/PointArray.hs0000644000000000000000000002600013315545734020521 0ustar0000000000000000{-# LANGUAGE FlexibleContexts, StandaloneDeriving, TypeFamilies #-} -- | Arrays, based on Data.Vector.Unboxed, indexed by @Point@. module Game.LambdaHack.Common.PointArray ( UnboxRepClass(..), Array(..), pindex, punindex , (!), accessI, (//), unsafeUpdateA, unsafeWriteA, unsafeWriteManyA , replicateA, replicateMA, generateA, generateMA, unfoldrNA, sizeA , foldrA, foldrA', foldlA', ifoldrA, ifoldrA', ifoldlA', foldMA', ifoldMA' , mapA, imapA, imapMA_, safeSetA, unsafeSetA , minIndexA, minLastIndexA, minIndexesA, maxIndexA, maxLastIndexA, forceA , fromListA, toListA #ifdef EXPOSE_INTERNAL -- * Internal operations , toUnboxRep #endif ) where import Prelude () import Game.LambdaHack.Common.Prelude import Control.Monad.ST.Strict import Data.Binary import Data.Vector.Binary () import qualified Data.Vector.Fusion.Bundle as Bundle import qualified Data.Vector.Generic as G import qualified Data.Vector.Unboxed as U import qualified Data.Vector.Unboxed.Mutable as VM import Game.LambdaHack.Common.Point class ( Ord c, Eq (UnboxRep c), Ord (UnboxRep c), Bounded (UnboxRep c) , Binary (UnboxRep c), U.Unbox (UnboxRep c) ) => UnboxRepClass c where type UnboxRep c type instance UnboxRep c = c toUnboxRepUnsafe :: c -> UnboxRep c -- has to be total fromUnboxRep :: UnboxRep c -> c -- has to be total instance UnboxRepClass Bool where toUnboxRepUnsafe c = c fromUnboxRep c = c instance UnboxRepClass Word8 where toUnboxRepUnsafe c = c fromUnboxRep c = c -- | Arrays indexed by @Point@. data Array c = Array { axsize :: X , aysize :: Y , avector :: U.Vector (UnboxRep c) } deriving instance UnboxRepClass c => Eq (Array c) instance Show (Array c) where show a = "PointArray.Array with size " ++ show (axsize a, aysize a) instance UnboxRepClass c => Binary (Array c) where put Array{..} = do put axsize put aysize put avector get = do axsize <- get aysize <- get avector <- get return $! Array{..} toUnboxRep :: UnboxRepClass c => c -> UnboxRep c {-# INLINE toUnboxRep #-} toUnboxRep c = #ifdef WITH_EXPENSIVE_ASSERTIONS assert (c <= fromUnboxRep maxBound) $ #endif toUnboxRepUnsafe c -- Note that @Ord@ on @Int@ is not monotonic wrt @Ord@ on @Point@. -- We need to keep it that way, because we want close xs to have close indexes. 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. (!) :: UnboxRepClass c => Array c -> Point -> c {-# INLINE (!) #-} (!) Array{..} p = fromUnboxRep $ avector U.! pindex axsize p accessI :: UnboxRepClass c => Array c -> Int -> UnboxRep c {-# INLINE accessI #-} accessI Array{..} p = avector `U.unsafeIndex` p -- | Construct an array updated with the association list. (//) :: UnboxRepClass c => Array c -> [(Point, c)] -> Array c {-# INLINE (//) #-} (//) Array{..} l = let v = avector U.// map (pindex axsize *** toUnboxRep) l in Array{avector = v, ..} unsafeUpdateA :: UnboxRepClass c => Array c -> [(Point, c)] -> () {-# INLINE unsafeUpdateA #-} unsafeUpdateA Array{..} l = runST $ do vThawed <- U.unsafeThaw avector mapM_ (\(p, c) -> VM.write vThawed (pindex axsize p) (toUnboxRep c)) l void $ U.unsafeFreeze vThawed unsafeWriteA :: UnboxRepClass c => Array c -> Point -> c -> () {-# INLINE unsafeWriteA #-} unsafeWriteA Array{..} p c = runST $ do vThawed <- U.unsafeThaw avector VM.write vThawed (pindex axsize p) (toUnboxRep c) void $ U.unsafeFreeze vThawed unsafeWriteManyA :: UnboxRepClass c => Array c -> [Point] -> c -> () {-# INLINE unsafeWriteManyA #-} unsafeWriteManyA Array{..} l c = runST $ do vThawed <- U.unsafeThaw avector let d = toUnboxRep c mapM_ (\p -> VM.write vThawed (pindex axsize p) d) l void $ U.unsafeFreeze vThawed -- | Create an array from a replicated element. replicateA :: UnboxRepClass c => X -> Y -> c -> Array c {-# INLINE replicateA #-} replicateA axsize aysize c = Array{avector = U.replicate (axsize * aysize) $ toUnboxRep c, ..} -- | Create an array from a replicated monadic action. replicateMA :: (Monad m, UnboxRepClass c) => X -> Y -> m c -> m (Array c) {-# INLINE replicateMA #-} replicateMA axsize aysize m = do v <- U.replicateM (axsize * aysize) $ liftM toUnboxRep m return $! Array{avector = v, ..} -- | Create an array from a function. generateA :: UnboxRepClass c => X -> Y -> (Point -> c) -> Array c {-# INLINE generateA #-} generateA axsize aysize f = let g n = toUnboxRep $ f $ punindex axsize n in Array{avector = U.generate (axsize * aysize) g, ..} -- | Create an array from a monadic function. generateMA :: (Monad m, UnboxRepClass c) => X -> Y -> (Point -> m c) -> m (Array c) {-# INLINE generateMA #-} generateMA axsize aysize fm = do let gm n = liftM toUnboxRep $ fm $ punindex axsize n v <- U.generateM (axsize * aysize) gm return $! Array{avector = v, ..} unfoldrNA :: UnboxRepClass c => X -> Y -> (b -> (c, b)) -> b -> Array c {-# INLINE unfoldrNA #-} unfoldrNA axsize aysize fm b = let gm = Just . first toUnboxRep . fm v = U.unfoldrN (axsize * aysize) gm b in Array {avector = v, ..} -- | Content identifiers array size. sizeA :: Array c -> (X, Y) {-# INLINE sizeA #-} sizeA Array{..} = (axsize, aysize) -- | Fold right over an array. foldrA :: UnboxRepClass c => (c -> a -> a) -> a -> Array c -> a {-# INLINE foldrA #-} foldrA f z0 Array{..} = U.foldr (\c a-> f (fromUnboxRep c) a) z0 avector -- | Fold right strictly over an array. foldrA' :: UnboxRepClass c => (c -> a -> a) -> a -> Array c -> a {-# INLINE foldrA' #-} foldrA' f z0 Array{..} = U.foldr' (\c a-> f (fromUnboxRep c) a) z0 avector -- | Fold left strictly over an array. foldlA' :: UnboxRepClass c => (a -> c -> a) -> a -> Array c -> a {-# INLINE foldlA' #-} foldlA' f z0 Array{..} = U.foldl' (\a c -> f a (fromUnboxRep c)) z0 avector -- | Fold left strictly over an array -- (function applied to each element and its index). ifoldlA' :: UnboxRepClass c => (a -> Point -> c -> a) -> a -> Array c -> a {-# INLINE ifoldlA' #-} ifoldlA' f z0 Array{..} = U.ifoldl' (\a n c -> f a (punindex axsize n) (fromUnboxRep c)) z0 avector -- | Fold right over an array -- (function applied to each element and its index). ifoldrA :: UnboxRepClass c => (Point -> c -> a -> a) -> a -> Array c -> a {-# INLINE ifoldrA #-} ifoldrA f z0 Array{..} = U.ifoldr (\n c a -> f (punindex axsize n) (fromUnboxRep c) a) z0 avector -- | Fold right strictly over an array -- (function applied to each element and its index). ifoldrA' :: UnboxRepClass c => (Point -> c -> a -> a) -> a -> Array c -> a {-# INLINE ifoldrA' #-} ifoldrA' f z0 Array{..} = U.ifoldr' (\n c a -> f (punindex axsize n) (fromUnboxRep c) a) z0 avector -- | Fold monadically strictly over an array. foldMA' :: (Monad m, UnboxRepClass c) => (a -> c -> m a) -> a -> Array c -> m a {-# INLINE foldMA' #-} foldMA' f z0 Array{..} = U.foldM' (\a c -> f a (fromUnboxRep c)) z0 avector -- | Fold monadically strictly over an array -- (function applied to each element and its index). ifoldMA' :: (Monad m, UnboxRepClass c) => (a -> Point -> c -> m a) -> a -> Array c -> m a {-# INLINE ifoldMA' #-} ifoldMA' f z0 Array{..} = U.ifoldM' (\a n c -> f a (punindex axsize n) (fromUnboxRep c)) z0 avector -- | Map over an array. mapA :: (UnboxRepClass c, UnboxRepClass d) => (c -> d) -> Array c -> Array d {-# INLINE mapA #-} mapA f Array{..} = Array{avector = U.map (toUnboxRep . f . fromUnboxRep) avector, ..} -- | Map over an array (function applied to each element and its index). imapA :: (UnboxRepClass c, UnboxRepClass d) => (Point -> c -> d) -> Array c -> Array d {-# INLINE imapA #-} imapA f Array{..} = let v = U.imap (\n c -> toUnboxRep $ f (punindex axsize n) (fromUnboxRep c)) avector in Array{avector = v, ..} -- | Map monadically over an array (function applied to each element -- and its index) and ignore the results. imapMA_ :: (Monad m, UnboxRepClass c) => (Point -> c -> m ()) -> Array c -> m () {-# INLINE imapMA_ #-} imapMA_ f Array{..} = U.imapM_ (\n c -> f (punindex axsize n) (fromUnboxRep c)) avector -- | Set all elements to the given value, in place. unsafeSetA :: UnboxRepClass c => c -> Array c -> Array c {-# INLINE unsafeSetA #-} unsafeSetA c Array{..} = runST $ do vThawed <- U.unsafeThaw avector VM.set vThawed (toUnboxRep c) vFrozen <- U.unsafeFreeze vThawed return $! Array{avector = vFrozen, ..} -- | Set all elements to the given value, in place, if possible. safeSetA :: UnboxRepClass c => c -> Array c -> Array c {-# INLINE safeSetA #-} safeSetA c Array{..} = Array{avector = U.modify (\v -> VM.set v (toUnboxRep c)) avector, ..} -- | Yield the point coordinates of a minimum element of the array. -- The array may not be empty. minIndexA :: UnboxRepClass c => Array c -> Point {-# INLINE minIndexA #-} minIndexA Array{..} = punindex axsize $ U.minIndex avector -- | Yield the point coordinates of the last minimum element of the array. -- The array may not be empty. minLastIndexA :: UnboxRepClass c => Array c -> Point {-# INLINE minLastIndexA #-} minLastIndexA Array{..} = 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 :: UnboxRepClass c => Array c -> [Point] {-# INLINE minIndexesA #-} minIndexesA Array{..} = Bundle.foldr imin [] . Bundle.indexed . G.stream $ avector where imin (i, x) acc = if x == minE then let !j = punindex axsize i in j : acc else acc !minE = U.minimum avector -- | Yield the point coordinates of the first maximum element of the array. -- The array may not be empty. maxIndexA :: UnboxRepClass c => Array c -> Point {-# INLINE maxIndexA #-} maxIndexA Array{..} = punindex axsize $ U.maxIndex avector -- | Yield the point coordinates of the last maximum element of the array. -- The array may not be empty. maxLastIndexA :: UnboxRepClass c => Array c -> Point {-# INLINE maxLastIndexA #-} maxLastIndexA Array{..} = 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 :: UnboxRepClass c => Array c -> Array c {-# INLINE forceA #-} forceA Array{..} = Array{avector = U.force avector, ..} fromListA :: UnboxRepClass c => X -> Y -> [c] -> Array c {-# INLINE fromListA #-} fromListA axsize aysize l = Array{avector = U.fromListN (axsize * aysize) $ map toUnboxRep l, ..} toListA :: UnboxRepClass c => Array c -> [c] {-# INLINE toListA #-} toListA Array{..} = map fromUnboxRep $ U.toList avector LambdaHack-0.8.3.0/Game/LambdaHack/Common/State.hs0000644000000000000000000002367613315545734017531 0ustar0000000000000000-- | The common server and client basic game state type and its operations. module Game.LambdaHack.Common.State ( -- * Basic game state, local or global State -- * State components , sdungeon, stotalDepth, sactorD, sitemD, sitemIxMap, sfactionD, stime, scops , sgold, shigh, sgameModeId, sdiscoKind, sdiscoAspect, sactorAspect -- * State construction , defStateGlobal, emptyState, localFromGlobal -- * State update , updateDungeon, updateDepth, updateActorD, updateItemD, updateItemIxMap , updateFactionD, updateTime, updateCOpsAndCachedData, updateGold , updateDiscoKind, updateDiscoAspect, updateActorAspect -- * State operations , getItemBody, aspectRecordFromItem, aspectRecordFromIid , aspectRecordFromActor, actorAspectInDungeon #ifdef EXPOSE_INTERNAL -- * Internal operations , unknownLevel, unknownTileMap #endif ) where import Prelude () import Game.LambdaHack.Common.Prelude import Data.Binary import qualified Data.EnumMap.Strict as EM import Game.LambdaHack.Common.Actor import qualified Game.LambdaHack.Common.Dice as Dice import Game.LambdaHack.Common.Faction import qualified Game.LambdaHack.Common.HighScore as HighScore import Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.ItemAspect as IA import Game.LambdaHack.Common.Kind import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Point import qualified Game.LambdaHack.Common.PointArray as PointArray import Game.LambdaHack.Common.Time import Game.LambdaHack.Content.CaveKind (CaveKind) import qualified Game.LambdaHack.Content.ItemKind as IK import Game.LambdaHack.Content.ModeKind import Game.LambdaHack.Content.TileKind (TileKind, unknownId) -- | View on the basic game state. -- The @remembered@ fields, in client copies of the state, carry only -- a subset of the full information that the server keeps. -- Clients never directly change their @State@, but apply -- atomic actions sent by the server to do so (and/or the server applies -- the actions to each client state in turn). data State = State { _sdungeon :: Dungeon -- ^ remembered dungeon , _stotalDepth :: Dice.AbsDepth -- ^ absolute dungeon depth, for item creation , _sactorD :: ActorDict -- ^ remembered actors in the dungeon , _sitemD :: ItemDict -- ^ remembered items in the dungeon , _sitemIxMap :: ItemIxMap -- ^ spotted items with the same kind index -- could be recomputed at resume, but small , _sfactionD :: FactionDict -- ^ remembered sides still in game , _stime :: Time -- ^ global game time, for UI display only , _scops :: COps -- ^ remembered content , _sgold :: Int -- ^ total value of human trinkets in dungeon , _shigh :: HighScore.ScoreDict -- ^ high score table , _sgameModeId :: ContentId ModeKind -- ^ current game mode , _sdiscoKind :: DiscoveryKind -- ^ item kind discoveries data , _sdiscoAspect :: DiscoveryAspect -- ^ item aspect data; could be recomputed , _sactorAspect :: ActorAspect -- ^ actor aspect records; is recomputed } deriving (Show, Eq) instance Binary State where put State{..} = do put _sdungeon put _stotalDepth put _sactorD put _sitemD put _sitemIxMap put _sfactionD put _stime put _sgold put _shigh put _sgameModeId put _sdiscoKind put _sdiscoAspect get = do _sdungeon <- get _stotalDepth <- get _sactorD <- get _sitemD <- get _sitemIxMap <- get _sfactionD <- get _stime <- get _sgold <- get _shigh <- get _sgameModeId <- get _sdiscoKind <- get _sdiscoAspect <- get let _scops = emptyCOps _sactorAspect = EM.empty return $! State{..} sdungeon :: State -> Dungeon sdungeon = _sdungeon stotalDepth :: State -> Dice.AbsDepth stotalDepth = _stotalDepth sactorD :: State -> ActorDict sactorD = _sactorD sitemD :: State -> ItemDict sitemD = _sitemD sitemIxMap :: State -> ItemIxMap sitemIxMap = _sitemIxMap sfactionD :: State -> FactionDict sfactionD = _sfactionD stime :: State -> Time stime = _stime scops :: State -> COps scops = _scops sgold :: State -> Int sgold = _sgold shigh :: State -> HighScore.ScoreDict shigh = _shigh sgameModeId :: State -> ContentId ModeKind sgameModeId = _sgameModeId sdiscoKind :: State -> DiscoveryKind sdiscoKind = _sdiscoKind sdiscoAspect :: State -> DiscoveryAspect sdiscoAspect = _sdiscoAspect sactorAspect :: State -> ActorAspect sactorAspect = _sactorAspect unknownLevel :: COps -> ContentId CaveKind -> Dice.AbsDepth -> X -> Y -> ([Point], [Point]) -> [Point] -> Int -> Bool -> Level unknownLevel COps{cotile} lkind ldepth lxsize lysize lstair lescape lexpl lnight = let outerId = ouniqGroup cotile "unknown outer fence" in Level { lkind , ldepth , lfloor = EM.empty , lembed = EM.empty , lactor = EM.empty , ltile = unknownTileMap outerId lxsize lysize , lxsize , lysize , lsmell = EM.empty , lstair , lescape , lseen = 0 , lexpl , ltime = timeZero , lnight } unknownTileMap :: ContentId TileKind -> Int -> Int -> TileMap unknownTileMap 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 -> Dice.AbsDepth -> FactionDict -> COps -> HighScore.ScoreDict -> ContentId ModeKind -> DiscoveryKind -> State defStateGlobal _sdungeon _stotalDepth _sfactionD _scops _shigh _sgameModeId _sdiscoKind = State { _sactorD = EM.empty , _sitemD = EM.empty , _sitemIxMap = EM.empty , _stime = timeZero , _sgold = 0 , _sdiscoAspect = EM.empty , _sactorAspect = EM.empty , .. } -- | Initial empty state. emptyState :: State emptyState = State { _sdungeon = EM.empty , _stotalDepth = Dice.AbsDepth 0 , _sactorD = EM.empty , _sitemD = EM.empty , _sitemIxMap = EM.empty , _sfactionD = EM.empty , _stime = timeZero , _scops = emptyCOps , _sgold = 0 , _shigh = HighScore.empty , _sgameModeId = toEnum 0 -- the initial value is unused , _sdiscoKind = EM.empty , _sdiscoAspect = EM.empty , _sactorAspect = EM.empty } -- | Local state created by removing secret information from global -- state components. localFromGlobal :: State -> State localFromGlobal State{..} = State { _sdungeon = EM.map (\Level{..} -> unknownLevel _scops lkind ldepth lxsize lysize lstair lescape lexpl lnight) _sdungeon , .. } -- | Update dungeon data within state. updateDungeon :: (Dungeon -> Dungeon) -> State -> State updateDungeon f s = s {_sdungeon = f (_sdungeon s)} -- | Update dungeon depth. updateDepth :: (Dice.AbsDepth -> Dice.AbsDepth) -> State -> State updateDepth f s = s {_stotalDepth = f (_stotalDepth s)} -- | Update the actor dictionary. updateActorD :: (ActorDict -> ActorDict) -> State -> State 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 the item kind index map. updateItemIxMap :: (ItemIxMap -> ItemIxMap) -> State -> State updateItemIxMap f s = s {_sitemIxMap = f (_sitemIxMap s)} -- | Update faction data within state. updateFactionD :: (FactionDict -> FactionDict) -> State -> State updateFactionD f s = s {_sfactionD = f (_sfactionD s)} -- | Update global time within state. updateTime :: (Time -> Time) -> State -> State updateTime f s = s {_stime = f (_stime s)} -- | Update content data within state and recompute the cached data. updateCOpsAndCachedData :: (COps -> COps) -> State -> State updateCOpsAndCachedData f s = let s2 = s {_scops = f (_scops s)} in s2 {_sactorAspect = actorAspectInDungeon s2} -- | Update total gold value in the dungeon. updateGold :: (Int -> Int) -> State -> State updateGold f s = s {_sgold = f (_sgold s)} updateDiscoKind :: (DiscoveryKind -> DiscoveryKind) -> State -> State updateDiscoKind f s = s {_sdiscoKind = f (_sdiscoKind s)} updateDiscoAspect :: (DiscoveryAspect -> DiscoveryAspect) -> State -> State updateDiscoAspect f s = s {_sdiscoAspect = f (_sdiscoAspect s)} updateActorAspect :: (ActorAspect -> ActorAspect) -> State -> State updateActorAspect f s = s {_sactorAspect = f (_sactorAspect s)} getItemBody :: ItemId -> State -> Item getItemBody iid s = sitemD s EM.! iid -- This is best guess, including mean aspect record, so we can take into -- consideration even the kind the item hides under. aspectRecordFromItem :: ItemId -> Item -> State -> IA.AspectRecord aspectRecordFromItem iid item s = let kindId = case jkind item of IdentityObvious ik -> ik IdentityCovered ix ik -> fromMaybe ik $ ix `EM.lookup` sdiscoKind s COps{coItemSpeedup} = scops s mean = IA.kmMean $ IK.getKindMean kindId coItemSpeedup in fromMaybe mean $ EM.lookup iid $ sdiscoAspect s aspectRecordFromIid :: ItemId -> State -> IA.AspectRecord aspectRecordFromIid iid s = aspectRecordFromItem iid (getItemBody iid s) s aspectRecordFromActor :: Actor -> State -> IA.AspectRecord aspectRecordFromActor b s = let processIid (iid, (k, _)) = (aspectRecordFromIid iid s, k) processBag ass = IA.sumAspectRecord $ map processIid ass in processBag $ EM.assocs (borgan b) ++ EM.assocs (beqp b) actorAspectInDungeon :: State -> ActorAspect actorAspectInDungeon s = EM.map (`aspectRecordFromActor` s) $ sactorD s LambdaHack-0.8.3.0/Game/LambdaHack/Common/Actor.hs0000644000000000000000000001600513315545734017505 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} -- | Actors in the game: heroes, monsters, etc. module Game.LambdaHack.Common.Actor ( -- * Actor identifiers ActorId -- * The@ Acto@r type, its components and operations on them , Actor(..), ResDelta(..), ActorAspect , deltaSerious, deltaMild, actorCanMelee , momentarySpeed, gearSpeed, braced, actorTemplate, waitedLastTurn, actorDying , hpTooLow, calmEnough, hpEnough , checkAdjacent, eqpOverfull, eqpFreeN -- * Assorted , ActorDict, monsterGenChance, smellTimeout ) where import Prelude () import Game.LambdaHack.Common.Prelude import Data.Binary import qualified Data.EnumMap.Strict as EM import Data.Int (Int64) import Data.Ratio import GHC.Generics (Generic) import qualified Game.LambdaHack.Common.Ability as Ability import qualified Game.LambdaHack.Common.Dice as Dice import Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.ItemAspect as IA import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.Random import Game.LambdaHack.Common.Time import Game.LambdaHack.Common.Vector -- | Actor properties that are changing throughout the game. -- If they appear dublets of properties of actor kinds, e.g. HP, -- they may be results of casting the dice specified in their respective -- actor kind and/or may be modified temporarily, but return -- to the original value from their respective kind over time. data Actor = Actor { -- The trunk of the actor's body (present also in @borgan@ or @beqp@) btrunk :: ItemId -- ^ the trunk organ of the actor's body -- Resources , bhp :: Int64 -- ^ current hit points * 1M , bhpDelta :: ResDelta -- ^ HP delta this turn * 1M , bcalm :: Int64 -- ^ current calm * 1M , bcalmDelta :: ResDelta -- ^ calm delta this turn * 1M -- Location , bpos :: Point -- ^ current position , boldpos :: Maybe Point -- ^ previous position, if any , blid :: LevelId -- ^ current level , bfid :: FactionId -- ^ faction the actor currently belongs to , btrajectory :: Maybe ([Vector], Speed) -- ^ trajectory the actor must -- travel and his travel speed -- Items , borgan :: ItemBag -- ^ organs , beqp :: ItemBag -- ^ personal equipment , binv :: ItemBag -- ^ personal inventory pack , bweapon :: Int -- ^ number of weapons among eqp and organs -- Assorted , bwait :: Bool -- ^ is the actor waiting right now? , bproj :: Bool -- ^ is a projectile? affects being able -- to fly through other projectiles, etc. } deriving (Show, Eq, Generic) instance Binary Actor -- The resource changes in the tuple are negative and positive, respectively. data ResDelta = ResDelta { resCurrentTurn :: (Int64, Int64) -- ^ resource change this player turn , resPreviousTurn :: (Int64, Int64) -- ^ resource change last player turn } deriving (Show, Eq, Generic) instance Binary ResDelta type ActorAspect = EM.EnumMap ActorId IA.AspectRecord -- | All actors on the level, indexed by actor identifier. type ActorDict = EM.EnumMap ActorId Actor deltaSerious :: ResDelta -> Bool deltaSerious ResDelta{..} = fst resCurrentTurn < 0 && fst resCurrentTurn /= minusM || fst resPreviousTurn < 0 && fst resPreviousTurn /= minusM deltaMild :: ResDelta -> Bool deltaMild ResDelta{..} = fst resCurrentTurn == minusM || fst resPreviousTurn == minusM actorCanMelee :: ActorAspect -> ActorId -> Actor -> Bool actorCanMelee actorAspect aid b = let ar = actorAspect EM.! aid actorMaxSk = IA.aSkills ar condUsableWeapon = bweapon b > 0 canMelee = EM.findWithDefault 0 Ability.AbMelee actorMaxSk > 0 in condUsableWeapon && canMelee -- | Current physical speed, whether from being pushed or from organs and gear. momentarySpeed :: Actor -> IA.AspectRecord -> Speed momentarySpeed !b ar = case btrajectory b of Nothing -> gearSpeed ar Just (_, speed) -> speed -- | The speed from organs and gear; being pushed is ignored. gearSpeed :: IA.AspectRecord -> Speed gearSpeed IA.AspectRecord{aSpeed} = toSpeed $ max minSpeed aSpeed -- see @minimalSpeed@ -- | Whether an actor is braced for combat this clip. braced :: Actor -> Bool braced = bwait actorTemplate :: ItemId -> Int64 -> Int64 -> Point -> LevelId -> FactionId -> Bool -> Actor actorTemplate btrunk bhp bcalm bpos blid bfid bproj = let btrajectory = Nothing boldpos = Nothing borgan = EM.empty beqp = EM.empty binv = EM.empty bweapon = 0 bwait = False bhpDelta = ResDelta (0, 0) (0, 0) bcalmDelta = ResDelta (0, 0) (0, 0) in Actor{..} waitedLastTurn :: Actor -> Bool {-# INLINE waitedLastTurn #-} waitedLastTurn = bwait actorDying :: Actor -> Bool actorDying b = bhp b <= 0 || bproj b && maybe True (null . fst) (btrajectory b) hpTooLow :: Actor -> IA.AspectRecord -> Bool hpTooLow b IA.AspectRecord{aMaxHP} = 5 * bhp b < xM aMaxHP && bhp b <= xM 40 || bhp b <= oneM calmEnough :: Actor -> IA.AspectRecord -> Bool calmEnough b IA.AspectRecord{aMaxCalm} = let calmMax = max 1 aMaxCalm in 2 * xM calmMax <= 3 * bcalm b && bcalm b > xM 10 hpEnough :: Actor -> IA.AspectRecord -> Bool hpEnough b IA.AspectRecord{aMaxHP} = xM aMaxHP <= 2 * bhp b && bhp b > oneM checkAdjacent :: Actor -> Actor -> Bool checkAdjacent sb tb = blid sb == blid tb && adjacent (bpos sb) (bpos tb) eqpOverfull :: Actor -> Int -> Bool eqpOverfull b n = let size = sum $ map fst $ EM.elems $ beqp b in assert (size <= 10 `blame` (b, n, size)) $ size + n > 10 eqpFreeN :: Actor -> Int eqpFreeN b = let size = sum $ map fst $ EM.elems $ beqp b in assert (size <= 10 `blame` (b, size)) $ 10 - size -- | Chance that a new monster is generated. Depends on the number -- of monsters already present, and on the level depth and its cave kind. monsterGenChance :: Dice.AbsDepth -> Dice.AbsDepth -> Int -> Int -> Rnd Bool monsterGenChance (Dice.AbsDepth n) (Dice.AbsDepth totalDepth) lvlAlreadySpawned actorCoeff = assert (totalDepth > 0 && n > 0) $ -- Heroes have to endure a level depth-sized wave of immediate -- spawners for each level and only then the monsters start -- to trickle more and more slowly, at the speed dictated -- by @actorCoeff@ specified in cave kind. -- On level 1/10, first 4 monsters spawn immediately, at level 5/10, -- 8 spawn immediately. In general at level n, n+3 spawn at once. let scaledDepth = n * 10 `div` totalDepth coeff = actorCoeff * (lvlAlreadySpawned - scaledDepth - 2) in chance $ 1%fromIntegral (coeff `max` 1) -- | How long until an actor's smell vanishes from a tile. smellTimeout :: Delta Time smellTimeout = timeDeltaScale (Delta timeTurn) 100 LambdaHack-0.8.3.0/Game/LambdaHack/Common/Level.hs0000644000000000000000000002256113315545734017510 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} -- | Inhabited dungeon levels and the operations to query and change them -- as the game progresses. module Game.LambdaHack.Common.Level ( -- * Dungeon LevelId, Dungeon , ascendInBranch, whereTo -- * The @Level@ type and its components , ItemFloor, ActorMap, TileMap, SmellMap, Level(..) -- * Component updates , updateFloor, updateEmbed, updateActorMap, updateTile, updateSmell -- * Level query , at, findPoint, findPos, findPosTry, findPosTry2 #ifdef EXPOSE_INTERNAL -- * Internal operations , assertSparseItems, assertSparseActors #endif ) where import Prelude () import Game.LambdaHack.Common.Prelude import Data.Binary import qualified Data.EnumMap.Strict as EM import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ContentData import qualified Game.LambdaHack.Common.Dice as Dice import Game.LambdaHack.Common.Item 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.Time import Game.LambdaHack.Content.CaveKind (CaveKind) import Game.LambdaHack.Content.TileKind (TileKind) -- | The complete dungeon is a map from level identifiers to levels. type Dungeon = EM.EnumMap LevelId Level -- | Levels in the current branch, one level up (or down) from the current. ascendInBranch :: Dungeon -> Bool -> LevelId -> [LevelId] ascendInBranch dungeon up lid = -- Currently there is just one branch, so the computation is simple. let (minD, maxD) = case (EM.minViewWithKey dungeon, EM.maxViewWithKey dungeon) of (Just ((s, _), _), Just ((e, _), _)) -> (s, e) _ -> error $ "null dungeon" `showFailure` dungeon ln = max minD $ min maxD $ toEnum $ fromEnum lid + if up then 1 else -1 in case EM.lookup ln dungeon of Just _ | ln /= lid -> [ln] _ | ln == lid -> [] _ -> ascendInBranch dungeon up ln -- jump over gaps -- | Compute the level identifier and stair position on the new level, -- after a level change. -- -- We assume there is never a staircase up and down at the same position. whereTo :: LevelId -- ^ level of the stairs -> Point -- ^ position of the stairs -> Maybe Bool -- ^ optional forced direction -> Dungeon -- ^ current game dungeon -> (LevelId, Point) -- ^ destination level and the pos of its receiving stairs whereTo lid pos mup dungeon = let lvl = dungeon EM.! lid (up, i) = case elemIndex pos $ fst $ lstair lvl of Just ifst -> (True, ifst) Nothing -> case elemIndex pos $ snd $ lstair lvl of Just isnd -> (False, isnd) Nothing -> case mup of Just forcedUp -> (forcedUp, 0) -- for ascending via, e.g., spells Nothing -> error $ "no stairs at" `showFailure` (lid, pos) !_A = assert (maybe True (== up) mup) () in case ascendInBranch dungeon up lid of [] | isJust mup -> (lid, pos) -- spell fizzles [] -> error $ "no dungeon level to go to" `showFailure` (lid, pos) ln : _ -> let lvlDest = dungeon EM.! ln stairsDest = (if up then snd else fst) (lstair lvlDest) in if length stairsDest < i + 1 then error $ "no stairs at index" `showFailure` (lid, pos) else (ln, stairsDest !! i) -- | Items located on map tiles. type ItemFloor = EM.EnumMap Point ItemBag -- | Items located on map tiles. type ActorMap = EM.EnumMap Point [ActorId] -- | Tile kinds on the map. type TileMap = PointArray.Array (ContentId TileKind) -- | Current smell on map tiles. type SmellMap = EM.EnumMap Point Time -- | A view on single, inhabited dungeon level. "Remembered" fields -- carry a subset of the info in the client copies of levels. data Level = Level { lkind :: ContentId CaveKind -- ^ the kind of cave the level is an instance of , ldepth :: Dice.AbsDepth -- ^ absolute depth of the level , lfloor :: ItemFloor -- ^ remembered items lying on the floor , lembed :: ItemFloor -- ^ remembered items embedded in the tile , lactor :: ActorMap -- ^ seen actors at positions on the level; -- could be recomputed at resume, but small enough , ltile :: TileMap -- ^ remembered level map , lxsize :: X -- ^ width of the level , lysize :: Y -- ^ height of the level , lsmell :: SmellMap -- ^ remembered smells on the level , lstair :: ([Point], [Point]) -- ^ positions of (up, down) stairs , lescape :: [Point] -- ^ positions of IK.Escape tiles , lseen :: Int -- ^ currently remembered clear tiles , lexpl :: Int -- ^ total number of explorable tiles , ltime :: Time -- ^ local time on the level (possibly frozen) , lnight :: Bool -- ^ whether the level is covered in darkness } deriving (Show, Eq) assertSparseItems :: ItemFloor -> ItemFloor assertSparseItems m = assert (EM.null (EM.filter EM.null m) `blame` "null floors found" `swith` m) m assertSparseActors :: ActorMap -> ActorMap assertSparseActors m = assert (EM.null (EM.filter null m) `blame` "null actor lists found" `swith` m) m updateFloor :: (ItemFloor -> ItemFloor) -> Level -> Level updateFloor f lvl = lvl {lfloor = f (lfloor lvl)} updateEmbed :: (ItemFloor -> ItemFloor) -> Level -> Level updateEmbed f lvl = lvl {lembed = f (lembed lvl)} updateActorMap :: (ActorMap -> ActorMap) -> Level -> Level updateActorMap f lvl = lvl {lactor = f (lactor lvl)} updateTile :: (TileMap -> TileMap) -> Level -> Level updateTile f lvl = lvl {ltile = f (ltile lvl)} updateSmell :: (SmellMap -> SmellMap) -> Level -> Level updateSmell f lvl = lvl {lsmell = f (lsmell lvl)} -- | Query for tile kinds on the map. at :: Level -> Point -> ContentId TileKind {-# INLINE at #-} at Level{ltile} p = ltile PointArray.! p -- | Find a random position on the map satisfying a predicate. findPoint :: X -> Y -> (Point -> Maybe Point) -> Rnd Point findPoint x y f = let search = do pxy <- randomR (0, (x - 1) * (y - 1)) let pos = PointArray.punindex x pxy case f pos of Just p -> return p Nothing -> search in search -- | Find a random position on the map satisfying a predicate. findPos :: TileMap -> (Point -> ContentId TileKind -> Bool) -> Rnd Point findPos ltile p = let (x, y) = PointArray.sizeA ltile search = do pxy <- randomR (0, (x - 1) * (y - 1)) let tile = ContentId $ ltile `PointArray.accessI` pxy pos = PointArray.punindex x pxy if p pos tile then return $! pos else search in search -- | Try to find a random position on the map satisfying -- conjunction of the mandatory and an optional predicate. -- If the permitted number of attempts is not enough, -- try again the same number of times without the next optional predicate, -- and fall back to trying as many times, as needed, with only the mandatory -- predicate. findPosTry :: Int -- ^ the number of tries -> TileMap -- ^ look up in this map -> (Point -> ContentId TileKind -> Bool) -- ^ mandatory predicate -> [Point -> ContentId TileKind -> Bool] -- ^ optional predicates -> Rnd Point {-# INLINE findPosTry #-} findPosTry numTries ltile m = findPosTry2 numTries ltile m [] undefined findPosTry2 :: Int -- ^ the number of tries -> TileMap -- ^ look up in this map -> (Point -> ContentId TileKind -> Bool) -- ^ mandatory predicate -> [Point -> ContentId TileKind -> Bool] -- ^ optional predicates -> (Point -> ContentId TileKind -> Bool) -- ^ good to have pred. -> [Point -> ContentId TileKind -> Bool] -- ^ worst case predicates -> Rnd Point findPosTry2 numTries ltile m0 l g r = assert (numTries > 0) $ let (x, y) = PointArray.sizeA ltile accomodate fallback _ [] = fallback -- fallback needs to be non-strict accomodate fallback m (hd : tl) = let search 0 = accomodate fallback m tl search !k = do pxy <- randomR (0, (x - 1) * (y - 1)) let tile = ContentId $ ltile `PointArray.accessI` pxy pos = PointArray.punindex x pxy if m pos tile && hd pos tile then return $! pos else search (k - 1) in search numTries in accomodate (accomodate (findPos ltile m0) m0 r) -- @pos@ or @tile@ not always needed, so not strict (\pos tile -> m0 pos tile && g pos tile) l instance Binary Level where put Level{..} = do put lkind put ldepth put (assertSparseItems lfloor) put (assertSparseItems lembed) put (assertSparseActors lactor) put ltile put lxsize put lysize put lsmell put lstair put lescape put lseen put lexpl put ltime put lnight get = do lkind <- get ldepth <- get lfloor <- get lembed <- get lactor <- get ltile <- get lxsize <- get lysize <- get lsmell <- get lstair <- get lescape <- get lseen <- get lexpl <- get ltime <- get lnight <- get return $! Level{..} LambdaHack-0.8.3.0/Game/LambdaHack/Common/Perception.hs0000644000000000000000000000630613315545734020550 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 to use a turn bumping into it first. Only tiles marked with Suspect -- can turn out to be another tile. (So, if all tiles are marked with -- Suspect, the player knows nothing for sure, but this should be avoided, -- because searching becomes too time-consuming.) -- Each actor sees adjacent tiles, even when blind, so adjacent tiles are -- known, so the actor can decide accurately whether to pass thorugh -- or alter, etc. -- -- Items are always real and visible. Actors are real, but can be invisible. -- Invisible actors in walls can't be hit, but are hinted at when altering -- the tile, so the player can flee or block. Invisible actors in open -- space can be hit. module Game.LambdaHack.Common.Perception ( PerVisible(..) , PerSmelled(..) , Perception(..) , PerLid , PerFid , totalVisible, totalSmelled , emptyPer, nullPer, addPer, diffPer ) where import Prelude () import Game.LambdaHack.Common.Prelude import Data.Binary import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES import GHC.Generics (Generic) import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Point -- | Visible positions. newtype PerVisible = PerVisible {pvisible :: ES.EnumSet Point} deriving (Show, Eq, Binary) -- | Smelled positions. newtype PerSmelled = PerSmelled {psmelled :: ES.EnumSet Point} deriving (Show, Eq, Binary) -- | The type representing the perception of a faction on a level. data Perception = Perception { psight :: PerVisible , psmell :: PerSmelled } deriving (Show, Eq, Generic) instance Binary Perception -- | Perception of a single faction, indexed by level identifier. type PerLid = EM.EnumMap LevelId Perception -- | Perception indexed by faction identifier. -- This can't be added to @FactionDict@, because clients can't see it -- for other factions. type PerFid = EM.EnumMap FactionId PerLid -- | The set of tiles visible by at least one hero. totalVisible :: Perception -> ES.EnumSet Point totalVisible = pvisible . psight -- | The set of tiles smelt by at least one hero. totalSmelled :: Perception -> ES.EnumSet Point totalSmelled = psmelled . psmell emptyPer :: Perception emptyPer = Perception { psight = PerVisible ES.empty , psmell = PerSmelled ES.empty } nullPer :: Perception -> Bool nullPer per = per == emptyPer addPer :: Perception -> Perception -> Perception addPer per1 per2 = Perception { psight = PerVisible $ totalVisible per1 `ES.union` totalVisible per2 , psmell = PerSmelled $ totalSmelled per1 `ES.union` totalSmelled per2 } diffPer :: Perception -> Perception -> Perception diffPer per1 per2 = Perception { psight = PerVisible $ totalVisible per1 ES.\\ totalVisible per2 , psmell = PerSmelled $ totalSmelled per1 ES.\\ totalSmelled per2 } LambdaHack-0.8.3.0/Game/LambdaHack/Common/ActorState.hs0000644000000000000000000005015613315545734020513 0ustar0000000000000000{-# LANGUAGE TupleSections #-} -- | Operations on the 'Actor' type, and related, that need the 'State' type, -- but not our custom monad types. module Game.LambdaHack.Common.ActorState ( fidActorNotProjAssocs, actorAssocs , fidActorRegularAssocs, fidActorRegularIds , foeRegularAssocs, foeRegularList, friendRegularAssocs, friendRegularList , bagAssocs, bagAssocsK, posToAidsLvl, posToAids, posToAssocs , nearbyFreePoints, calculateTotal, itemPrice, mergeItemQuant, findIid , combinedInv, combinedEqp, combinedOrgan, combinedItems, combinedFromLore , getActorBody, getActorAspect, canTraverse , getCarriedAssocsAndTrunk, getCarriedIidCStore, getContainerBag , getFloorBag, getEmbedBag, getBodyStoreBag , mapActorItems_, getActorAssocs, getActorAssocsK , memActor, getLocalTime, regenCalmDelta, actorInAmbient, canDeAmbientList , actorSkills, dispEnemy, itemToFull, fullAssocs, kitAssocs , getItemKindId, getIidKindId, getItemKind, getIidKind , getItemKindIdServer, getIidKindIdServer, getItemKindServer, getIidKindServer , storeFromC, aidFromC, lidFromC, posFromC , isStair, anyFoeAdj, actorAdjacentAssocs , armorHurtBonus, inMelee ) where import Prelude () import Game.LambdaHack.Common.Prelude import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES import Data.Int (Int64) import GHC.Exts (inline) import qualified Game.LambdaHack.Common.Ability as Ability import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.ItemAspect as IA import Game.LambdaHack.Common.Kind import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.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) import qualified Game.LambdaHack.Content.TileKind as TK fidActorNotProjAssocs :: FactionId -> State -> [(ActorId, Actor)] fidActorNotProjAssocs fid s = let f (_, b) = not (bproj b) && bfid b == fid in filter f $ EM.assocs $ sactorD s actorAssocs :: (FactionId -> Bool) -> LevelId -> State -> [(ActorId, Actor)] actorAssocs p lid s = let f (_, b) = blid b == lid && p (bfid b) in filter f $ EM.assocs $ sactorD s actorRegularAssocs :: (FactionId -> Bool) -> LevelId -> State -> [(ActorId, Actor)] {-# INLINE actorRegularAssocs #-} actorRegularAssocs p lid s = let f (_, b) = not (bproj b) && blid b == lid && p (bfid b) && bhp b > 0 in filter f $ EM.assocs $ sactorD s fidActorRegularAssocs :: FactionId -> LevelId -> State -> [(ActorId, Actor)] fidActorRegularAssocs fid lid s = actorRegularAssocs (== fid) lid s fidActorRegularIds :: FactionId -> LevelId -> State -> [ActorId] fidActorRegularIds fid lid s = map fst $ actorRegularAssocs (== fid) lid s foeRegularAssocs :: FactionId -> LevelId -> State -> [(ActorId, Actor)] foeRegularAssocs fid lid s = let fact = (EM.! fid) . sfactionD $ s in actorRegularAssocs (inline isFoe fid fact) lid s foeRegularList :: FactionId -> LevelId -> State -> [Actor] foeRegularList fid lid s = let fact = (EM.! fid) . sfactionD $ s in map snd $ actorRegularAssocs (inline isFoe fid fact) lid s friendRegularAssocs :: FactionId -> LevelId -> State -> [(ActorId, Actor)] friendRegularAssocs fid lid s = let fact = (EM.! fid) . sfactionD $ s in actorRegularAssocs (inline isFriend fid fact) lid s friendRegularList :: FactionId -> LevelId -> State -> [Actor] friendRegularList fid lid s = let fact = (EM.! fid) . sfactionD $ s in map snd $ actorRegularAssocs (inline isFriend fid fact) lid s bagAssocs :: State -> ItemBag -> [(ItemId, Item)] bagAssocs s bag = let iidItem iid = (iid, getItemBody iid s) in map iidItem $ EM.keys bag bagAssocsK :: State -> ItemBag -> [(ItemId, (Item, ItemQuant))] bagAssocsK s bag = let iidItem (iid, kit) = (iid, (getItemBody iid s, kit)) in map iidItem $ EM.assocs bag posToAidsLvl :: Point -> Level -> [ActorId] {-# INLINE posToAidsLvl #-} posToAidsLvl pos lvl = EM.findWithDefault [] pos $ lactor lvl posToAids :: Point -> LevelId -> State -> [ActorId] posToAids pos lid s = posToAidsLvl pos $ sdungeon s EM.! lid posToAssocs :: Point -> LevelId -> State -> [(ActorId, Actor)] posToAssocs pos lid s = let l = posToAidsLvl pos $ sdungeon s EM.! lid in map (\aid -> (aid, getActorBody aid s)) l nearbyFreePoints :: (ContentId TileKind -> Bool) -> Point -> LevelId -> State -> [Point] nearbyFreePoints f start lid s = let lvl@Level{lxsize, lysize} = sdungeon s EM.! lid good p = f (lvl `at` p) && Tile.isWalkable (coTileSpeedup $ scops s) (lvl `at` p) && null (posToAidsLvl p lvl) ps = nub $ start : concatMap (vicinity lxsize lysize) ps in filter good ps -- | Calculate loot's worth for a given faction. calculateTotal :: FactionId -> State -> (ItemBag, Int) calculateTotal fid s = let bag = combinedItems fid s items = map (\(iid, (k, _)) -> (getItemBody iid s, k)) $ EM.assocs bag price (item, k) = itemPrice k $ getItemKind item s in (bag, sum $ map price items) -- | Price an item, taking count into consideration. itemPrice :: Int -> IK.ItemKind -> Int itemPrice jcount itemKind = case lookup "valuable" $ IK.ifreq itemKind of Just k -> jcount * k Nothing -> 0 mergeItemQuant :: ItemQuant -> ItemQuant -> ItemQuant mergeItemQuant (k2, it2) (k1, it1) = (k1 + k2, it1 ++ it2) findIid :: ActorId -> FactionId -> ItemId -> State -> [(ActorId, (Actor, CStore))] findIid leader fid iid s = let actors = fidActorNotProjAssocs fid s itemsOfActor (aid, b) = let itemsOfCStore store = let bag = getBodyStoreBag b store s in map (\iid2 -> (iid2, (aid, (b, store)))) (EM.keys bag) stores = [CInv, CEqp, COrgan] ++ [CSha | aid == leader] in concatMap itemsOfCStore stores items = concatMap itemsOfActor actors in map snd $ filter ((== iid) . fst) items combinedInv :: FactionId -> State -> ItemBag combinedInv fid s = let bs = inline fidActorNotProjAssocs fid s in EM.unionsWith mergeItemQuant $ map (binv . snd) bs combinedEqp :: FactionId -> State -> ItemBag combinedEqp fid s = let bs = inline fidActorNotProjAssocs fid s in EM.unionsWith mergeItemQuant $ map (beqp . snd) bs -- Trunk not considered (if stolen). combinedOrgan :: FactionId -> State -> ItemBag combinedOrgan fid s = let bs = inline fidActorNotProjAssocs fid s in EM.unionsWith mergeItemQuant $ map (borgan . snd) bs -- Trunk not considered (if stolen). combinedItems :: FactionId -> State -> ItemBag combinedItems fid s = let shaBag = gsha $ sfactionD s EM.! fid bs = map snd $ inline fidActorNotProjAssocs fid s in EM.unionsWith mergeItemQuant $ map binv bs ++ map beqp bs ++ [shaBag] combinedFromLore :: SLore -> FactionId -> State -> ItemBag combinedFromLore slore fid s = case slore of SItem -> combinedItems fid s SOrgan -> combinedOrgan fid s STrunk -> combinedOrgan fid s STmp -> combinedOrgan fid s SBlast -> EM.empty SEmbed -> EM.empty getActorBody :: ActorId -> State -> Actor {-# INLINE getActorBody #-} getActorBody aid s = sactorD s EM.! aid getActorAspect :: ActorId -> State -> IA.AspectRecord {-# INLINE getActorAspect #-} getActorAspect aid s = sactorAspect s EM.! aid -- Check that the actor can move, also between levels and through doors. -- Otherwise, it's too awkward for human player to control, e.g., -- being stuck in a room with revolving doors closing after one turn -- and the player needing to micromanage opening such doors with -- another actor all the time. Completely immovable actors -- e.g., an impregnable surveillance camera in a crowded corridor, -- are less of a problem due to micromanagment, but more due to -- the constant disturbing of other actor's running, etc.. canTraverse :: ActorId -> State -> Bool canTraverse aid s = let actorMaxSk = IA.aSkills $ getActorAspect aid s in EM.findWithDefault 0 Ability.AbMove actorMaxSk > 0 && EM.findWithDefault 0 Ability.AbAlter actorMaxSk >= fromEnum TK.talterForStairs getCarriedAssocsAndTrunk :: Actor -> State -> [(ItemId, Item)] getCarriedAssocsAndTrunk b s = -- The trunk is important for a case of spotting a caught projectile -- with a stolen projecting item. This actually does happen. let trunk = EM.singleton (btrunk b) (1, []) in bagAssocs s $ EM.unionsWith const [binv b, beqp b, borgan b, trunk] 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)] getContainerBag :: Container -> State -> ItemBag getContainerBag c s = case c of CFloor lid p -> getFloorBag lid p s CEmbed lid p -> getEmbedBag lid p s CActor aid cstore -> let b = getActorBody aid s in getBodyStoreBag b cstore s CTrunk{} -> error $ "" `showFailure` c getFloorBag :: LevelId -> Point -> State -> ItemBag getFloorBag lid p s = EM.findWithDefault EM.empty p $ lfloor (sdungeon s EM.! lid) getEmbedBag :: LevelId -> Point -> State -> ItemBag getEmbedBag lid p s = EM.findWithDefault EM.empty p $ lembed (sdungeon s EM.! lid) getBodyStoreBag :: Actor -> CStore -> State -> ItemBag getBodyStoreBag b cstore s = case cstore of CGround -> getFloorBag (blid b) (bpos b) s COrgan -> borgan b CEqp -> beqp b 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 = getBodyStoreBag b cstore s mapM_ (uncurry $ f cstore) $ EM.assocs bag mapM_ g sts getActorAssocs :: ActorId -> CStore -> State -> [(ItemId, Item)] getActorAssocs aid cstore s = let b = getActorBody aid s in bagAssocs s $ getBodyStoreBag b cstore s getActorAssocsK :: ActorId -> CStore -> State -> [(ItemId, (Item, ItemQuant))] getActorAssocsK aid cstore s = let b = getActorBody aid s in bagAssocsK s $ getBodyStoreBag b cstore s -- | Checks if the actor is present on the current level. -- The order of argument here and in other functions is set to allow -- -- > b <- getsState (memActor a) memActor :: ActorId -> LevelId -> State -> Bool memActor aid lid s = maybe False ((== lid) . blid) $ EM.lookup aid $ sactorD s -- | Get current time from the dungeon data. getLocalTime :: LevelId -> State -> Time getLocalTime lid s = ltime $ sdungeon s EM.! lid regenCalmDelta :: ActorId -> Actor -> State -> Int64 regenCalmDelta aid body s = let calmIncr = oneM -- normal rate of calm regen IA.AspectRecord{aMaxCalm} = getActorAspect aid s maxDeltaCalm = xM aMaxCalm - bcalm body fact = (EM.! bfid body) . sfactionD $ s -- Worry actor by (even projectile) enemies felt (even if not seen) -- on the level within 3 steps. Even dying, but not hiding in wait. isHeardFoe (!p, l) = -- In case of multiple projectiles on the same position, -- the following is not reliable, but that's OK (and fast). let b = case l of aid2 : _ -> getActorBody aid2 s [] -> error $ "" `showFailure` (aid, body, p) in inline chessDist p (bpos body) <= 3 && not (waitedLastTurn b) -- uncommon && inline isFoe (bfid body) fact (bfid b) -- costly in if any isHeardFoe $ EM.assocs $ lactor $ sdungeon s EM.! blid body then minusM -- even if all calmness spent, keep informing the client else min calmIncr (max 0 maxDeltaCalm) -- in case Calm is over max actorInAmbient :: Actor -> State -> Bool actorInAmbient b s = let lvl = (EM.! blid b) . sdungeon $ s in Tile.isLit (coTileSpeedup $ scops s) (lvl `at` bpos b) canDeAmbientList :: Actor -> State -> [Point] canDeAmbientList b s = let COps{coTileSpeedup} = scops s lvl = (EM.! blid b) . sdungeon $ s posDeAmbient p = let t = lvl `at` p in Tile.isWalkable coTileSpeedup t -- no time to waste altering && not (Tile.isLit coTileSpeedup t) in if Tile.isLit coTileSpeedup (lvl `at` bpos b) then filter posDeAmbient (vicinityUnsafe $ bpos b) else [] actorSkills :: Maybe ActorId -> ActorId -> State -> Ability.Skills actorSkills mleader aid s = let body = getActorBody aid s ar = getActorAspect aid s player = gplayer . (EM.! bfid body) . sfactionD $ s skillsFromTactic = Ability.tacticSkills $ ftactic player factionSkills | Just aid == mleader = Ability.zeroSkills | otherwise = fskillsOther player `Ability.addSkills` skillsFromTactic itemSkills = IA.aSkills ar in itemSkills `Ability.addSkills` factionSkills -- Check whether an actor can displace an enemy. We assume they are adjacent. -- If the actor is not, in fact, an enemy, we let it displace. dispEnemy :: ActorId -> ActorId -> Ability.Skills -> State -> Bool dispEnemy source target actorMaxSk s = let hasBackup b = let adjacentAssocs = actorAdjacentAssocs b s fact = sfactionD s EM.! bfid b friend (_, b2) = not (bproj b2) && isFriend (bfid b) fact (bfid b2) && bhp b2 > 0 in any friend adjacentAssocs sb = getActorBody source s tb = getActorBody target s tfact = sfactionD s EM.! bfid tb in bproj tb || not (isFoe (bfid tb) tfact (bfid sb)) || not (actorDying tb || braced tb || EM.findWithDefault 0 Ability.AbMove actorMaxSk <= 0 || hasBackup sb && hasBackup tb) -- solo actors are flexible itemToFull :: ItemId -> State -> ItemFull itemToFull iid s = itemToFull6 (scops s) (sdiscoKind s) (sdiscoAspect s) iid (getItemBody iid s) fullAssocs :: ActorId -> [CStore] -> State -> [(ItemId, ItemFull)] fullAssocs aid cstores s = let allAssocs = concatMap (\cstore -> getActorAssocsK aid cstore s) cstores iToFull (iid, (item, _kit)) = (iid, itemToFull6 (scops s) (sdiscoKind s) (sdiscoAspect s) iid item) in map iToFull allAssocs kitAssocs :: ActorId -> [CStore] -> State -> [(ItemId, ItemFullKit)] kitAssocs aid cstores s = let allAssocs = concatMap (\cstore -> getActorAssocsK aid cstore s) cstores iToFull (iid, (item, kit)) = (iid, ( itemToFull6 (scops s) (sdiscoKind s) (sdiscoAspect s) iid item , kit )) in map iToFull allAssocs getItemKindId :: Item -> State -> ContentId IK.ItemKind getItemKindId item s = case jkind item of IdentityObvious ik -> ik IdentityCovered ix ik -> fromMaybe ik $ EM.lookup ix $ sdiscoKind s getIidKindId :: ItemId -> State -> ContentId IK.ItemKind getIidKindId iid s = getItemKindId (getItemBody iid s) s getItemKind :: Item -> State -> IK.ItemKind getItemKind item s = okind (coitem $ scops s) $ getItemKindId item s getIidKind :: ItemId -> State -> IK.ItemKind getIidKind iid s = getItemKind (getItemBody iid s) s getItemKindIdServer :: Item -> State -> ContentId IK.ItemKind getItemKindIdServer item s = case jkind item of IdentityObvious ik -> ik IdentityCovered ix _ik -> fromJust $ EM.lookup ix $ sdiscoKind s getIidKindIdServer :: ItemId -> State -> ContentId IK.ItemKind getIidKindIdServer iid s = getItemKindIdServer (getItemBody iid s) s getItemKindServer :: Item -> State -> IK.ItemKind getItemKindServer item s = okind (coitem $ scops s) $ getItemKindIdServer item s getIidKindServer :: ItemId -> State -> IK.ItemKind getIidKindServer iid s = getItemKindServer (getItemBody iid s) s storeFromC :: Container -> CStore storeFromC c = case c of CFloor{} -> CGround CEmbed{} -> CGround CActor _ cstore -> cstore CTrunk{} -> error $ "" `showFailure` c aidFromC :: Container -> Maybe ActorId aidFromC CFloor{} = Nothing aidFromC CEmbed{} = Nothing aidFromC (CActor aid _) = Just aid aidFromC c@CTrunk{} = error $ "" `showFailure` 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{} _ = error $ "" `showFailure` c posFromC :: Container -> State -> Point posFromC (CFloor _ pos) _ = pos posFromC (CEmbed _ pos) _ = pos posFromC (CActor aid _) s = bpos $ getActorBody aid s posFromC c@CTrunk{} _ = error $ "" `showFailure` c isStair :: LevelId -> Point -> State -> Bool isStair lid p s = let bag = getEmbedBag lid p s ks = map (flip getIidKind s) $ EM.keys bag in any (any IK.isEffAscend . IK.ieffects) ks -- | Require that any non-dying foe is adjacent. We include even -- projectiles that explode when stricken down, because they can be caught -- and then they don't explode, so it makes sense to focus on handling them. -- If there are many projectiles in a single adjacent position, we only test -- the first one, the one that would be hit in melee (this is not optimal -- if the actor would need to flee instead of meleeing, but fleeing -- with *many* projectiles adjacent is a possible waste of a move anyway). anyFoeAdj :: ActorId -> State -> Bool anyFoeAdj aid s = let body = getActorBody aid s lvl = (EM.! blid body) . sdungeon $ s fact = (EM.! bfid body) . sfactionD $ s f !mv = case posToAidsLvl (shift (bpos body) mv) lvl of [] -> False aid2 : _ -> g $ getActorBody aid2 s g !b = inline isFoe (bfid body) fact (bfid b) && bhp b > 0 -- uncommon in any f moves actorAdjacentAssocs :: Actor -> State -> [(ActorId, Actor)] {-# INLINE actorAdjacentAssocs #-} actorAdjacentAssocs body s = let lvl = (EM.! blid body) . sdungeon $ s f !mv = posToAidsLvl (shift (bpos body) mv) lvl g !aid = (aid, getActorBody aid s) in map g $ concatMap f moves armorHurtBonus :: ActorId -> ActorId -> State -> Int armorHurtBonus source target s = let sb = getActorBody source s tb = getActorBody target s trim200 n = min 200 $ max (-200) n block200 b n = min 200 $ max (-200) $ n + if braced tb then b else 0 sar = sactorAspect s EM.! source tar = sactorAspect s EM.! target itemBonus = trim200 (IA.aHurtMelee sar) - if bproj sb then block200 25 (IA.aArmorRanged tar) else block200 50 (IA.aArmorMelee tar) in 100 + min 99 (max (-99) itemBonus) -- at least 1% of damage gets through -- | Check if any non-dying foe (projectile or not) is adjacent -- to any of our normal actors (whether they can melee or just need to flee, -- in which case alert is needed so that they are not slowed down by others). -- This is needed only by AI and computed as lazily as possible. inMelee :: FactionId -> LevelId -> State -> Bool inMelee !fid !lid s = let fact = sfactionD s EM.! fid f !b = blid b == lid && inline isFoe fid fact (bfid b) -- costly && bhp b > 0 -- uncommon allFoes = filter f $ EM.elems $ sactorD s g !b = bfid b == fid && blid b == lid && not (bproj b) && bhp b > 0 allOurs = filter g $ EM.elems $ sactorD s -- We assume foes are less numerous, even though they may come -- from multiple factions and they contain projectiles, -- because we see all our actors, while many foes may be hidden. -- Consequently, we allocate the set of foe positions -- and avoid allocating ours, by iterating over our actors. -- This in O(mn) instead of O(m+n), but it allocates -- less and multiplicative constants are lower. -- We inspect adjacent locations of foe positions, not of ours, -- thus increasing allocation a bit, but not by much, because -- the set should be rather saturated. -- If there are no foes in sight, we don't iterate at all. setFoeVicinity = ES.fromList $ concatMap (vicinityUnsafe . bpos) allFoes in not (ES.null setFoeVicinity) -- shortcut && any (\b -> bpos b `ES.member` setFoeVicinity) allOurs LambdaHack-0.8.3.0/Game/LambdaHack/Common/RingBuffer.hs0000644000000000000000000000306713315545734020472 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} -- | Ring buffers. module Game.LambdaHack.Common.RingBuffer ( RingBuffer , empty, cons, uncons, toList, length ) where import Prelude () import Game.LambdaHack.Common.Prelude hiding (length, uncons) import Data.Binary import qualified Data.Foldable as Foldable import qualified Data.Sequence as Seq import GHC.Generics (Generic) -- | Ring buffers of a size determined at initialization. data RingBuffer a = RingBuffer { rbCarrier :: Seq.Seq a , rbMaxSize :: Int , rbNext :: Int , rbLength :: Int } deriving (Show, Generic) instance Binary a => Binary (RingBuffer a) -- Only takes O(log n)). empty :: Int -> a -> RingBuffer a empty size dummy = let rbMaxSize = max 1 size in RingBuffer (Seq.replicate rbMaxSize dummy) rbMaxSize 0 0 cons :: a -> RingBuffer a -> RingBuffer a cons a RingBuffer{..} = let incNext = (rbNext + 1) `mod` rbMaxSize incLength = min rbMaxSize $ rbLength + 1 in RingBuffer (Seq.update rbNext a rbCarrier) rbMaxSize incNext incLength uncons :: RingBuffer a -> Maybe (a, RingBuffer a) uncons RingBuffer{..} = let decNext = (rbNext - 1) `mod` rbMaxSize in if rbLength == 0 then Nothing else Just ( Seq.index rbCarrier decNext , RingBuffer rbCarrier rbMaxSize decNext (rbLength - 1) ) toList :: RingBuffer a -> [a] toList RingBuffer{..} = let l = Foldable.toList rbCarrier start = (rbNext + rbMaxSize - rbLength) `mod` rbMaxSize in take rbLength $ drop start $ l ++ l length :: RingBuffer a -> Int length RingBuffer{rbLength} = rbLength LambdaHack-0.8.3.0/Game/LambdaHack/Common/File.hs0000644000000000000000000000051713315545734017315 0ustar0000000000000000-- | Saving/loading to files, with serialization and compression. module Game.LambdaHack.Common.File ( encodeEOF, strictDecodeEOF , tryCreateDir, doesFileExist, tryWriteFile, readFile, renameFile ) where import Prelude () #ifdef USE_JSFILE import Game.LambdaHack.Common.JSFile #else import Game.LambdaHack.Common.HSFile #endif LambdaHack-0.8.3.0/Game/LambdaHack/Common/ReqFailure.hs0000644000000000000000000002076713315545734020506 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} -- | Possible causes of failure of request. module Game.LambdaHack.Common.ReqFailure ( ReqFailure(..) , impossibleReqFailure, showReqFailure , permittedPrecious, permittedProject, permittedProjectAI, permittedApply #ifdef EXPOSE_INTERNAL -- * Internal operations #endif ) where import Prelude () import Game.LambdaHack.Common.Prelude import Data.Binary import GHC.Generics (Generic) import Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.ItemAspect as IA import Game.LambdaHack.Common.Time import qualified Game.LambdaHack.Content.ItemKind as IK -- | Possible causes of failure of request. data ReqFailure = MoveUnskilled | MoveNothing | MeleeUnskilled | MeleeSelf | MeleeDistant | DisplaceUnskilled | DisplaceDistant | DisplaceAccess | DisplaceProjectiles | DisplaceDying | DisplaceBraced | DisplaceImmobile | DisplaceSupported | AlterUnskilled | AlterUnwalked | AlterDistant | AlterBlockActor | AlterBlockItem | AlterNothing | WaitUnskilled | MoveItemUnskilled | EqpOverfull | EqpStackFull | ApplyUnskilled | ApplyRead | ApplyOutOfReach | ApplyCharging | ApplyNoEffects | ItemNothing | ItemNotCalm | NotCalmPrecious | ProjectUnskilled | ProjectAimOnself | ProjectBlockTerrain | ProjectBlockActor | ProjectLobable | ProjectOutOfReach | TriggerNothing | NoChangeDunLeader deriving (Show, Eq, Generic) instance Binary ReqFailure impossibleReqFailure :: ReqFailure -> Bool impossibleReqFailure reqFailure = case reqFailure of MoveUnskilled -> False -- unidentified skill items MoveNothing -> True MeleeUnskilled -> False -- unidentified skill items MeleeSelf -> True MeleeDistant -> True DisplaceUnskilled -> False -- unidentified skill items DisplaceDistant -> True DisplaceAccess -> True DisplaceProjectiles -> True DisplaceDying -> True DisplaceBraced -> True DisplaceImmobile -> False -- unidentified skill items DisplaceSupported -> False AlterUnskilled -> False -- unidentified skill items AlterUnwalked -> False AlterDistant -> True AlterBlockActor -> True -- adjacent actor always visible AlterBlockItem -> True -- adjacent item always visible AlterNothing -> True WaitUnskilled -> False -- unidentified skill items MoveItemUnskilled -> False -- unidentified skill items EqpOverfull -> True EqpStackFull -> True ApplyUnskilled -> False -- unidentified skill items ApplyRead -> False -- unidentified skill items ApplyOutOfReach -> True ApplyCharging -> False -- if aspect record unknown, charging unknown ApplyNoEffects -> False -- if effects unknown, can't prevent it ItemNothing -> True ItemNotCalm -> False -- unidentified skill items NotCalmPrecious -> False -- unidentified skill items ProjectUnskilled -> False -- unidentified skill items ProjectAimOnself -> True ProjectBlockTerrain -> True -- adjacent terrain always visible ProjectBlockActor -> True -- adjacent actor always visible ProjectLobable -> False -- unidentified skill items ProjectOutOfReach -> True TriggerNothing -> True -- terrain underneath always visible NoChangeDunLeader -> True showReqFailure :: ReqFailure -> Text showReqFailure reqFailure = case reqFailure of MoveUnskilled -> "unskilled actors cannot move" MoveNothing -> "wasting time on moving into obstacle" MeleeUnskilled -> "unskilled actors cannot melee" MeleeSelf -> "trying to melee oneself" MeleeDistant -> "trying to melee a distant foe" DisplaceUnskilled -> "unskilled actors cannot displace" 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" AlterUnwalked -> "unskilled actors cannot enter tiles" AlterDistant -> "trying to alter a distant tile" AlterBlockActor -> "blocked by an actor" AlterBlockItem -> "jammed by an item" AlterNothing -> "wasting time on altering nothing" WaitUnskilled -> "unskilled actors cannot wait" MoveItemUnskilled -> "unskilled actors cannot move items" 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" ApplyNoEffects -> "cannot apply an item that produces no effects" ItemNothing -> "wasting time on void item manipulation" ItemNotCalm -> "you are too alarmed to use 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" ProjectLobable -> "lobbing an 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" -- 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 forced calmE ItemFull{itemKind, itemDisco} = let isPrecious = IK.Precious `elem` IK.ifeature itemKind in if not forced && not calmE && isPrecious then Left NotCalmPrecious else Right $ IK.Durable `elem` IK.ifeature itemKind || case itemDisco of ItemDiscoFull{} -> True _ -> not isPrecious -- Simplified, faster version, for inner AI loop. permittedPreciousAI :: Bool -> ItemFull -> Bool permittedPreciousAI calmE ItemFull{itemKind, itemDisco} = let isPrecious = IK.Precious `elem` IK.ifeature itemKind in if not calmE && isPrecious then False else IK.Durable `elem` IK.ifeature itemKind || case itemDisco of ItemDiscoFull{} -> True _ -> not isPrecious permittedProject :: Bool -> Int -> Bool -> ItemFull -> Either ReqFailure Bool permittedProject forced skill calmE itemFull@ItemFull{itemKind} = if | not forced && skill < 1 -> Left ProjectUnskilled | not forced && IK.Lobable `elem` IK.ifeature itemKind && skill < 3 -> Left ProjectLobable | otherwise -> let badSlot = case IK.getEqpSlot itemKind of Just IA.EqpSlotLightSource -> False Just _ -> True Nothing -> IK.goesIntoEqp itemKind in if badSlot then Right False else permittedPrecious forced calmE itemFull -- Simplified, faster and more permissive version, for inner AI loop. permittedProjectAI :: Int -> Bool -> ItemFull -> Bool permittedProjectAI skill calmE itemFull@ItemFull{itemKind} = if | skill < 1 -> False | IK.Lobable `elem` IK.ifeature itemKind && skill < 3 -> False | otherwise -> permittedPreciousAI calmE itemFull permittedApply :: Time -> Int -> Bool-> ItemFull -> ItemQuant -> Either ReqFailure Bool permittedApply localTime skill calmE itemFull@ItemFull{itemKind, itemSuspect} kit = if | IK.isymbol itemKind == '?' && skill < 2 -> Left ApplyRead -- ApplyRead has precedence for the case of embedced items that -- can't be applied if they require reading, but can even if actor -- completely unskilled (as long as he is able to alter the tile). | skill < 1 -> Left ApplyUnskilled -- We assume if the item has a timeout, all or most of interesting -- effects are under Recharging, so no point activating if not recharged. -- Note that if client doesn't know the timeout, here we leak the fact -- that the item is still charging, but the client risks destruction -- if the item is, in fact, recharged and is not durable -- (very likely in case of jewellery), so it's OK (the message may be -- somewhat alarming though). | not $ hasCharge localTime itemFull kit -> Left ApplyCharging | otherwise -> if null (IK.ieffects itemKind) && not itemSuspect then Left ApplyNoEffects else permittedPrecious False calmE itemFull LambdaHack-0.8.3.0/Game/LambdaHack/Common/Item.hs0000644000000000000000000002527413315545734017343 0ustar0000000000000000{-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving #-} -- | Weapons, treasure and all the other items in the game. module Game.LambdaHack.Common.Item ( ItemId, Item(..), ItemIdentity(..) , ItemKindIx, ItemDisco(..), ItemFull(..), ItemFullKit , DiscoveryKind, DiscoveryAspect, ItemIxMap, Benefit(..), DiscoveryBenefit , ItemTimer, ItemQuant, ItemBag, ItemDict , itemToFull6, aspectRecordFull , strongestSlot, hasCharge, strongestMelee, unknownMeleeBonus, tmpMeleeBonus #ifdef EXPOSE_INTERNAL -- * Internal operations , unknownAspect #endif ) where import Prelude () import Game.LambdaHack.Common.Prelude import Data.Binary import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES import Data.Hashable (Hashable) import qualified Data.Ix as Ix import qualified Data.Ord as Ord import GHC.Generics (Generic) import qualified Game.LambdaHack.Common.Dice as Dice import Game.LambdaHack.Common.Flavour import qualified Game.LambdaHack.Common.ItemAspect as IA import Game.LambdaHack.Common.Kind import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.Time import qualified Game.LambdaHack.Content.ItemKind as IK -- | A unique identifier of an item in the dungeon. newtype ItemId = ItemId Int deriving (Show, Eq, Ord, Enum, Binary) -- | Game items in actor possesion or strewn around the dungeon. -- The information contained in this time is available to the player -- from the moment the item is first seen and is never mutated. -- -- Some items are not created identified (@IdentityCovered@). -- Then they are presented as having a template kind that is really -- not their own, though usually close. Full kind information about -- item's kind is available through the @ItemKindIx@ index once the item -- is identified and full information about the value of item's aspect record -- is available elsewhere (both @IdentityObvious@ and @IdentityCovered@ -- items may or may not need identification of their aspect record). data Item = Item { jkind :: ItemIdentity -- ^ the kind of the item, or an indiretion , jlid :: LevelId -- ^ lowest level the item was created at , jfid :: Maybe FactionId -- ^ the faction that created the item, if any , jflavour :: Flavour -- ^ flavour, always the real one, not hidden; -- people may not recognize shape, but they -- remember colour and old vs fancy look } deriving (Show, Eq, Generic) instance Hashable Item instance Binary Item -- | Either the explicit obvious kind of the item or the kind it's hidden under, -- with the details covered under the index indirection. data ItemIdentity = IdentityObvious (ContentId IK.ItemKind) | IdentityCovered ItemKindIx (ContentId IK.ItemKind) deriving (Show, Eq, Generic) instance Hashable ItemIdentity instance Binary ItemIdentity -- | The map of item ids to item aspect reocrd. The full map is known -- by the server. type DiscoveryAspect = EM.EnumMap ItemId IA.AspectRecord -- | An index of the kind identifier of an item. Clients have partial knowledge -- how these idexes map to kind ids. They gain knowledge by identifying items. -- The indexes and kind identifiers are 1-1. newtype ItemKindIx = ItemKindIx Word16 deriving (Show, Eq, Ord, Enum, Ix.Ix, Hashable, Binary) -- | The secret part of the information about an item. If a faction -- knows the aspect record of the item (the @kmConst@ flag is set or -- the @itemAspect@ field is @Left@), this is a complete secret information. -- Items that don't need second identification may be identified or not and both -- cases are OK (their display flavour will differ and that may be the point). -- -- The @itemAspect@ accessor it to be used unconditionally only on the server -- where it's guaranteed to be safe. data ItemDisco = ItemDiscoMean IA.KindMean | ItemDiscoFull {itemAspect :: IA.AspectRecord} deriving (Show, Eq, Ord) -- No speedup from making fields non-strict. -- | Full information about an item. data ItemFull = ItemFull { itemBase :: Item , itemKindId :: ContentId IK.ItemKind , itemKind :: IK.ItemKind , itemDisco :: ItemDisco , itemSuspect :: Bool } deriving Show type ItemFullKit = (ItemFull, ItemQuant) -- | The map of item kind indexes to item kind ids. -- The full map, as known by the server, is 1-1. -- Because it's sparse and changes, we don't represent it as an (unboxed) -- vector, until it becomes a bottleneck (if ever, likely on JS, where only -- vectors are fast). type DiscoveryKind = EM.EnumMap ItemKindIx (ContentId IK.ItemKind) -- | The map of item kind indexes to identifiers of items that have that kind. -- Used to update data about items when their kinds become known, e.g., -- AI item use benefit data. type ItemIxMap = EM.EnumMap ItemKindIx (ES.EnumSet ItemId) -- | Fields are intentionally kept non-strict, because they are recomputed -- often, but not used every time. The fields are, in order: -- 1. whether the item should be kept in equipment (not in pack nor stash) -- 2. the total benefit from picking the item up (to use or to put in equipment) -- 3. the benefit of applying the item to self -- 4. the (usually negative) benefit of hitting a foe in meleeing with the item -- 5. the (usually negative) benefit of flinging an item at an opponent data Benefit = Benefit { benInEqp :: ~Bool , benPickup :: ~Double , benApply :: ~Double , benMelee :: ~Double , benFling :: ~Double } deriving (Show, Generic) instance Binary Benefit type DiscoveryBenefit = EM.EnumMap ItemId Benefit type ItemTimer = [Time] -- | Number of items in a bag, together with recharging timer, in case of -- items that need recharging, exists only temporarily or auto-activate -- at regular intervals. type ItemQuant = (Int, ItemTimer) -- | A bag of items, e.g., one of the stores of an actor or the items -- on a particular floor position or embedded in a particular map tile. type ItemBag = EM.EnumMap ItemId ItemQuant -- | All items in the dungeon (including in actor inventories), -- indexed by item identifier. type ItemDict = EM.EnumMap ItemId Item itemToFull6 :: COps -> DiscoveryKind -> DiscoveryAspect -> ItemId -> Item -> ItemFull itemToFull6 COps{coitem, coItemSpeedup} discoKind discoAspect iid itemBase = let (itemKindId, itemSuspect) = case jkind itemBase of IdentityObvious ik -> (ik, False) IdentityCovered ix ik -> maybe (ik, True) (\ki -> (ki, False)) $ ix `EM.lookup` discoKind itemKind = okind coitem itemKindId km = IK.getKindMean itemKindId coItemSpeedup -- If the kind is not identified, we know nothing about the real -- aspect record, so we at least assume they are variable. itemAspectMean | itemSuspect = km {IA.kmConst = False} | otherwise = km itemDisco = case EM.lookup iid discoAspect of Just itemAspect -> ItemDiscoFull itemAspect Nothing -> ItemDiscoMean itemAspectMean in ItemFull {..} aspectRecordFull :: ItemFull -> IA.AspectRecord aspectRecordFull itemFull = case itemDisco itemFull of ItemDiscoMean itemAspectMean -> IA.kmMean itemAspectMean ItemDiscoFull itemAspect -> itemAspect -- This ignores items that don't go into equipment, as determined in @inEqp@. -- They are removed from equipment elsewhere via @harmful@. strongestSlot :: DiscoveryBenefit -> IA.EqpSlot -> [(ItemId, ItemFullKit)] -> [(Int, (ItemId, ItemFullKit))] strongestSlot discoBenefit eqpSlot is = let f (iid, (itemFull, kit)) = let Benefit{benInEqp, benPickup} = discoBenefit EM.! iid in if not benInEqp then Nothing else Just $ let ben = if eqpSlot == IA.EqpSlotWeapon -- For equipping/unequipping a weapon we take into -- account not only melee power, but also aspects, etc. then ceiling benPickup else IA.prEqpSlot eqpSlot $ aspectRecordFull itemFull in (ben, (iid, (itemFull, kit))) in sortBy (flip $ Ord.comparing fst) $ mapMaybe f is hasCharge :: Time -> ItemFull -> ItemQuant -> Bool hasCharge localTime itemFull (itemK, itemTimer) = let timeout = IA.aTimeout $ aspectRecordFull itemFull timeoutTurns = timeDeltaScale (Delta timeTurn) timeout charging startT = timeShift startT timeoutTurns > localTime it1 = filter charging itemTimer in length it1 < itemK strongestMelee :: Maybe DiscoveryBenefit -> Time -> [(ItemId, ItemFullKit)] -> [(Double, (ItemId, ItemFullKit))] strongestMelee _ _ [] = [] strongestMelee mdiscoBenefit localTime kitAss = -- For simplicity we assume, if weapon not recharged, all important effects, -- good and bad, are disabled and only raw damage remains. let f (iid, (itemFull, kit)) = let rawDmg = (IK.damageUsefulness $ itemKind itemFull, (iid, (itemFull, kit))) knownOrConstantAspects = case itemDisco itemFull of ItemDiscoMean IA.KindMean{kmConst} -> kmConst ItemDiscoFull{} -> True unIDedBonus | knownOrConstantAspects = 0 | otherwise = 1000 -- exceptionally strong weapon in case mdiscoBenefit of Just discoBenefit -> let Benefit{benMelee} = discoBenefit EM.! iid -- For fighting, as opposed to equipping, we value weapon -- only for its raw damage and harming effects. dmg = if hasCharge localTime itemFull kit then (- benMelee, (iid, (itemFull, kit))) else rawDmg in first (+ unIDedBonus) dmg Nothing -> rawDmg -- not interested about ID -- We can't filter out weapons that are not harmful to victim -- (@benMelee >= 0), because actors use them if nothing else available, -- e.g., geysers, bees. This is intended and fun. in sortBy (flip $ Ord.comparing fst) $ map f kitAss unknownAspect :: (IA.Aspect -> [Dice.Dice]) -> ItemFull -> Bool unknownAspect f ItemFull{itemKind=IK.ItemKind{iaspects}, ..} = case itemDisco of ItemDiscoMean IA.KindMean{kmConst} -> let unknown x = let (minD, maxD) = Dice.minmaxDice x in minD /= maxD in itemSuspect || not kmConst && or (concatMap (map unknown . f) iaspects) ItemDiscoFull{} -> False -- all known unknownMeleeBonus :: [ItemFull] -> Bool unknownMeleeBonus = let p (IA.AddHurtMelee k) = [k] p _ = [] f itemFull b = b || unknownAspect p itemFull in foldr f False tmpMeleeBonus :: [ItemFullKit] -> Int tmpMeleeBonus kitAss = let f (itemFull, (itemK, _)) k = itemK * IA.aHurtMelee (aspectRecordFull itemFull) + k in foldr f 0 $ filter (IK.isTmpCondition . itemKind . fst) kitAss LambdaHack-0.8.3.0/Game/LambdaHack/Common/HSFile.hs0000644000000000000000000000506513315545734017553 0ustar0000000000000000-- | Saving/loading to files, with serialization and compression. module Game.LambdaHack.Common.HSFile ( encodeEOF, strictDecodeEOF , tryCreateDir, doesFileExist, tryWriteFile, readFile, renameFile #ifdef EXPOSE_INTERNAL -- * Internal operations , encodeData #endif ) where import Prelude () import Game.LambdaHack.Common.Prelude import qualified Codec.Compression.Zlib as Z import qualified Control.Exception as Ex import Data.Binary import qualified Data.ByteString.Lazy as LBS import System.Directory import System.FilePath import System.IO (IOMode (..), hClose, openBinaryFile, readFile, withBinaryFile, writeFile) -- | Serialize, compress and save data. -- Note that LBS.writeFile opens the file in binary mode. encodeData :: Binary a => FilePath -> a -> IO () encodeData path a = do let tmpPath = path <.> "tmp" Ex.bracketOnError (openBinaryFile tmpPath WriteMode) (\h -> hClose h >> removeFile tmpPath) (\h -> do LBS.hPut h . Z.compress . encode $ a hClose h renameFile tmpPath path ) -- | Serialize, compress and save data with an EOF marker. -- The @OK@ is used as an EOF marker to ensure any apparent problems with -- corrupted files are reported to the user ASAP. encodeEOF :: Binary a => FilePath -> a -> IO () encodeEOF path a = encodeData path (a, "OK" :: String) -- | Read, decompress and deserialize data with an EOF marker. -- The @OK@ EOF marker ensures any easily detectable file corruption -- is discovered and reported before the function returns. strictDecodeEOF :: Binary a => FilePath -> IO a strictDecodeEOF path = withBinaryFile path ReadMode $ \h -> do c <- LBS.hGetContents h let (a, n) = decode $ Z.decompress c if n == ("OK" :: String) then return $! a else fail $ "Fatal error: corrupted file " ++ path -- | Try to create a directory, if it doesn't exist. We catch exceptions -- in case many clients try to do the same thing at the same time. tryCreateDir :: FilePath -> IO () tryCreateDir dir = do dirExists <- doesDirectoryExist dir unless dirExists $ Ex.handle (\(_ :: Ex.IOException) -> return ()) (createDirectory dir) -- | Try to write a file, given content, if the file not already there. -- We catch exceptions in case many clients try to do the same thing -- at the same time. tryWriteFile :: FilePath -> String -> IO () tryWriteFile path content = do fileExists <- doesFileExist path unless fileExists $ Ex.handle (\(_ :: Ex.IOException) -> return ()) (writeFile path content) LambdaHack-0.8.3.0/Game/LambdaHack/Common/Flavour.hs0000644000000000000000000001115713315545734020056 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} -- | The appearance of in-game items, as communicated to the player. module Game.LambdaHack.Common.Flavour ( -- * The @Flavour@ type Flavour(Flavour) , -- * Constructors zipPlain, zipFancy, zipLiquid , -- * Accessors flavourToColor, flavourToName -- * Assorted , colorToPlainName, colorToFancyName, colorToTeamName #ifdef EXPOSE_INTERNAL -- * Internal operations , FancyName, colorToLiquidName #endif ) where import Prelude () import Game.LambdaHack.Common.Prelude import Control.DeepSeq import Data.Binary import Data.Bits (unsafeShiftL, unsafeShiftR, (.&.)) import Data.Hashable (Hashable (hashWithSalt), hashUsing) import GHC.Generics (Generic) import Game.LambdaHack.Common.Color data FancyName = Plain | Fancy | Liquid deriving (Show, Eq, Ord, Enum, Bounded, Generic) instance NFData FancyName -- | The type of item flavours. data Flavour = Flavour { fancyName :: FancyName -- ^ how fancy should the colour description be , baseColor :: Color -- ^ the colour of the flavour } deriving (Show, Eq, Ord, Generic) instance Enum Flavour where fromEnum Flavour{..} = unsafeShiftL (fromEnum fancyName) 8 + fromEnum baseColor toEnum n = Flavour (toEnum $ unsafeShiftR n 8) (toEnum $ n .&. (2 ^ (8 :: Int) - 1)) instance Hashable Flavour where hashWithSalt = hashUsing fromEnum instance Binary Flavour where put = put . (fromIntegral :: Int -> Word16) . fromEnum get = fmap (toEnum . (fromIntegral :: Word16 -> Int)) get instance NFData 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) -- | 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 = "golden" 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.8.3.0/Game/LambdaHack/Common/Color.hs0000644000000000000000000001520213315545734017511 0ustar0000000000000000{-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving, MagicHash, TypeFamilies #-} -- | Colours and text attributes. module Game.LambdaHack.Common.Color ( -- * Colours Color(..) , defFG, isBright, darkCol, brightCol, stdCol, colorToRGB -- * Complete text attributes , Highlight (..), Attr(..) , defAttr -- * Characters with attributes , AttrChar(..), AttrCharW32(..) , attrCharToW32, attrCharFromW32 , fgFromW32, bgFromW32, charFromW32, attrFromW32, attrEnumFromW32 , spaceAttrW32, retAttrW32, attrChar2ToW32, attrChar1ToW32 ) where import Prelude () import Game.LambdaHack.Common.Prelude import Control.DeepSeq import Data.Binary import Data.Bits (unsafeShiftL, unsafeShiftR, (.&.)) import qualified Data.Char as Char import Data.Hashable (Hashable) import Data.Word (Word32) import GHC.Exts (Int (I#)) import GHC.Generics (Generic) import GHC.Prim (int2Word#) import GHC.Word (Word32 (W32#)) import qualified Game.LambdaHack.Common.PointArray as PointArray -- | 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 Binary Color where put = putWord8 . toEnum . fromEnum get = fmap (toEnum . fromEnum) getWord8 instance Hashable Color instance NFData Color -- | The default colours, to optimize attribute setting. defFG :: Color defFG = White -- | A helper for the terminal frontends that display bright via bold. isBright :: Color -> Bool isBright c = c >= BrBlack -- | Colour sets. 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. -- -- Warning: SDL frontend sadly duplicates this code. colorToRGB :: Color -> Text colorToRGB Black = "#000000" colorToRGB Red = "#D50000" colorToRGB Green = "#00AA00" colorToRGB Brown = "#CA4A00" 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 -> Text _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" -- | Additional map cell highlight, e.g., a colorful square around the cell -- or a colorful background. data Highlight = HighlightNone | HighlightRed | HighlightBlue | HighlightYellow | HighlightGrey | HighlightWhite | HighlightMagenta deriving (Show, Eq, Ord, Enum, Bounded, Generic) -- | Text attributes: foreground color and highlight. data Attr = Attr { fg :: Color -- ^ foreground colour , bg :: Highlight -- ^ highlight } deriving (Show, Eq, Ord) instance Enum Attr where fromEnum Attr{..} = unsafeShiftL (fromEnum fg) 8 + fromEnum bg toEnum n = Attr (toEnum $ unsafeShiftR n 8) (toEnum $ n .&. (2 ^ (8 :: Int) - 1)) -- | The default attribute, to optimize attribute setting. defAttr :: Attr defAttr = Attr defFG HighlightNone -- | Character to display, with its attribute. data AttrChar = AttrChar { acAttr :: Attr , acChar :: Char } deriving (Show, Eq, Ord) -- This implementation is faster than @Int@, because some vector updates -- can be done without going to and from @Int@. -- | Optimized representation of 'AttrChar'. newtype AttrCharW32 = AttrCharW32 {attrCharW32 :: Word32} deriving (Show, Eq, Ord, Enum, Binary) instance PointArray.UnboxRepClass AttrCharW32 where type UnboxRep AttrCharW32 = Word32 toUnboxRepUnsafe = attrCharW32 fromUnboxRep = AttrCharW32 attrCharToW32 :: AttrChar -> AttrCharW32 attrCharToW32 AttrChar{acAttr=Attr{..}, acChar} = AttrCharW32 $ toEnum $ unsafeShiftL (fromEnum fg) 8 + fromEnum bg + unsafeShiftL (Char.ord acChar) 16 attrCharFromW32 :: AttrCharW32 -> AttrChar attrCharFromW32 !w = AttrChar (Attr (toEnum $ fromEnum $ unsafeShiftR (attrCharW32 w) 8 .&. (2 ^ (8 :: Int) - 1)) (toEnum $ fromEnum $ attrCharW32 w .&. (2 ^ (8 :: Int) - 1))) (Char.chr $ fromEnum $ unsafeShiftR (attrCharW32 w) 16) {- surprisingly, this is slower: attrCharFromW32 :: AttrCharW32 -> AttrChar attrCharFromW32 !w = AttrChar (attrFromW32 w) (charFromW32 w) -} fgFromW32 :: AttrCharW32 -> Color {-# INLINE fgFromW32 #-} fgFromW32 w = toEnum $ fromEnum $ unsafeShiftR (attrCharW32 w) 8 .&. (2 ^ (8 :: Int) - 1) bgFromW32 :: AttrCharW32 -> Highlight {-# INLINE bgFromW32 #-} bgFromW32 w = toEnum $ fromEnum $ attrCharW32 w .&. (2 ^ (8 :: Int) - 1) charFromW32 :: AttrCharW32 -> Char {-# INLINE charFromW32 #-} charFromW32 w = Char.chr $ fromEnum $ unsafeShiftR (attrCharW32 w) 16 attrFromW32 :: AttrCharW32 -> Attr {-# INLINE attrFromW32 #-} attrFromW32 w = Attr (fgFromW32 w) (bgFromW32 w) attrEnumFromW32 :: AttrCharW32 -> Int {-# INLINE attrEnumFromW32 #-} attrEnumFromW32 !w = fromEnum $ attrCharW32 w .&. (2 ^ (16 :: Int) - 1) spaceAttrW32 :: AttrCharW32 spaceAttrW32 = attrCharToW32 $ AttrChar defAttr ' ' retAttrW32 :: AttrCharW32 retAttrW32 = attrCharToW32 $ AttrChar defAttr '\n' attrChar2ToW32 :: Color -> Char -> AttrCharW32 {-# INLINE attrChar2ToW32 #-} attrChar2ToW32 fg acChar = case unsafeShiftL (fromEnum fg) 8 + unsafeShiftL (Char.ord acChar) 16 of I# i -> AttrCharW32 $ W32# (int2Word# i) {- the hacks save one allocation (?) (before fits-in-32bits check) compared to unsafeShiftL (fromEnum fg) 8 + unsafeShiftL (Char.ord acChar) 16 -} attrChar1ToW32 :: Char -> AttrCharW32 {-# INLINE attrChar1ToW32 #-} attrChar1ToW32 = let fgNum = unsafeShiftL (fromEnum White) 8 in \acChar -> case fgNum + unsafeShiftL (Char.ord acChar) 16 of I# i -> AttrCharW32 $ W32# (int2Word# i) LambdaHack-0.8.3.0/Game/LambdaHack/Common/Prelude.hs0000644000000000000000000000376313315545734020044 0ustar0000000000000000-- | Custom Prelude, compatible across many GHC versions. module Game.LambdaHack.Common.Prelude ( module Prelude.Compat , module Control.Monad.Compat , module Data.List.Compat , module Data.Maybe , module Data.Monoid.Compat , module Control.Exception.Assert.Sugar , Text, (<+>), tshow, divUp, (<$$>), partitionM, length, null , (***), (&&&), first, second ) where import Prelude () import Prelude.Compat hiding (appendFile, length, null, readFile, writeFile, (<>)) import Control.Applicative import Control.Arrow (first, second, (&&&), (***)) import Control.Monad.Compat import Data.List.Compat hiding (length, null) import qualified Data.List.Compat as List import Data.Maybe import Data.Monoid.Compat import Control.Exception.Assert.Sugar (allB, assert, blame, showFailure, swith) import Data.Text (Text) import qualified Data.Text as T (pack) import NLP.Miniutter.English ((<+>)) -- | Show and pack the result. tshow :: Show a => a -> Text tshow x = T.pack $ show x infixl 7 `divUp` -- | Integer division, rounding up. divUp :: Integral a => a -> a -> a {-# INLINE divUp #-} divUp n k = (n + k - 1) `div` k infixl 4 <$$> (<$$>) :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b) h <$$> m = fmap h <$> m partitionM :: Applicative m => (a -> m Bool) -> [a] -> m ([a], [a]) {-# INLINE partitionM #-} partitionM p = foldr (\a -> liftA2 (\b -> (if b then first else second) (a :)) (p a)) (pure ([], [])) -- | A version specialized to lists to avoid errors such as taking length -- of @Maybe [a]@ instead of @[a]@. -- Such errors are hard to detect, because the type of elements of the list -- is not constrained. length :: [a] -> Int length = List.length -- | A version specialized to lists to avoid errors such as taking null -- of @Maybe [a]@ instead of @[a]@. -- Such errors are hard to detect, because the type of elements of the list -- is not constrained. null :: [a] -> Bool null = List.null LambdaHack-0.8.3.0/Game/LambdaHack/Common/Point.hs0000644000000000000000000001262213315545734017527 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 , originPoint #ifdef EXPOSE_INTERNAL -- * Internal operations , maxLevelDim, blaXY, balancedWord #endif ) where import Prelude () import Game.LambdaHack.Common.Prelude 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 (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 -- 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@. -- Note that the conversion is not monotonic wrt the natural @Ord@ instance, -- because we want adjacent points in line to have adjacent enumerations, -- because some of the screen layout and most of processing is line-by-line. -- Consequently, one can use EM.fromAscList on @(1, 8)..(10, 8)@, but not on -- @(1, 7)..(10, 9)@. instance Enum Point where fromEnum (Point x y) = #ifdef WITH_EXPENSIVE_ASSERTIONS assert (x >= 0 && y >= 0 && x <= maxLevelDim && y <= maxLevelDim `blame` "invalid point coordinates" `swith` (x, y)) #endif (x + unsafeShiftL y maxLevelDimExponent) toEnum n = Point (n .&. maxLevelDim) (unsafeShiftR n maxLevelDimExponent) -- | 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 -- | The distance between two points in the chessboard metric. chessDist :: Point -> Point -> Int chessDist (Point x0 y0) (Point x1 y1) = max (abs (x1 - x0)) (abs (y1 - y0)) -- | Squared euclidean distance between two points. euclidDistSq :: Point -> Point -> Int euclidDistSq (Point x0 y0) (Point x1 y1) = (x1 - x0) ^ (2 :: Int) + (y1 - y0) ^ (2 :: Int) -- | Checks whether two points are adjacent on the map -- (horizontally, vertically or diagonally). adjacent :: Point -> Point -> Bool {-# INLINE adjacent #-} adjacent s t = chessDist s t == 1 -- | Checks that a point belongs to an area. inside :: Point -> (X, Y, X, Y) -> Bool 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 = error $ "diagonal fromTo" `showFailure` ((x0, y0), (x1, y1)) in result originPoint :: Point originPoint = Point 0 0 LambdaHack-0.8.3.0/Game/LambdaHack/Common/MonadStateRead.hs0000644000000000000000000000616113315545734021272 0ustar0000000000000000{-# LANGUAGE TupleSections #-} -- | Game state reading monad and basic operations. module Game.LambdaHack.Common.MonadStateRead ( MonadStateRead(..) , getState, getLevel, nUI , getGameMode, isNoConfirmsGame, getEntryArena, pickWeaponM ) where import Prelude () import Game.LambdaHack.Common.Prelude import qualified Data.EnumMap.Strict as EM 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.Kind import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.ReqFailure import Game.LambdaHack.Common.State import Game.LambdaHack.Content.ModeKind -- | Monad for reading game state. A state monad with state modification -- disallowed (another constraint is needed to permit that). -- The basic server and client monads are like that, because server -- and clients freely modify their internal session data, but don't modify -- the main game state, except in very restricted and synchronized way. class (Monad m, Functor m, Applicative m) => MonadStateRead m where getsState :: (State -> a) -> m a getState :: MonadStateRead m => m State getState = getsState id getLevel :: MonadStateRead m => LevelId -> m Level getLevel lid = getsState $ (EM.! lid) . sdungeon nUI :: MonadStateRead m => m Int nUI = do factionD <- getsState sfactionD return $! length $ filter (fhasUI . gplayer) $ EM.elems factionD getGameMode :: MonadStateRead m => m ModeKind getGameMode = do COps{comode} <- getsState scops t <- getsState sgameModeId return $! okind comode t isNoConfirmsGame :: MonadStateRead m => m Bool isNoConfirmsGame = do gameMode <- getGameMode return $! maybe False (> 0) $ lookup "no confirms" $ mfreq gameMode 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) _ -> error $ "empty dungeon" `showFailure` dungeon f [] = 0 f ((ln, _, _) : _) = ln return $! max minD $ min maxD $ toEnum $ f $ ginitial fact pickWeaponM :: MonadStateRead m => Maybe DiscoveryBenefit -> [(ItemId, ItemFullKit)] -> Ability.Skills -> ActorId -> m [(Double, (ItemId, ItemFullKit))] pickWeaponM mdiscoBenefit kitAss actorSk source = do sb <- getsState $ getActorBody source localTime <- getsState $ getLocalTime (blid sb) ar <- getsState $ getActorAspect source let calmE = calmEnough sb ar forced = bproj sb permitted = permittedPrecious forced calmE preferredPrecious = either (const False) id . permitted permAssocs = filter (preferredPrecious . fst . snd) kitAss strongest = strongestMelee mdiscoBenefit localTime permAssocs return $! if | forced -> map (1,) kitAss | EM.findWithDefault 0 Ability.AbMelee actorSk <= 0 -> [] | otherwise -> strongest LambdaHack-0.8.3.0/Game/LambdaHack/Common/Save.hs0000644000000000000000000001322013315545734017327 0ustar0000000000000000-- | Saving and restoring game state, used by both server and clients. module Game.LambdaHack.Common.Save ( ChanSave, saveToChan, wrapInSaves, restoreGame, saveNameCli, saveNameSer #ifdef EXPOSE_INTERNAL -- * Internal operations , loopSave, vExevLib, showVersion2, delayPrint #endif ) where import Prelude () import Game.LambdaHack.Common.Prelude -- Cabal import qualified Paths_LambdaHack as Self (version) import Control.Concurrent import Control.Concurrent.Async import qualified Control.Exception as Ex import Data.Binary import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.IO as T import Data.Version import System.FilePath import System.IO (hFlush, stdout) import qualified System.Random as R import Game.LambdaHack.Common.File import Game.LambdaHack.Common.Kind import Game.LambdaHack.Common.Misc (FactionId, appDataDir) import Game.LambdaHack.Content.RuleKind type ChanSave a = MVar (Maybe a) saveToChan :: ChanSave a -> a -> IO () saveToChan toSave s = do -- Wipe out previous candidates for saving. void $ tryTakeMVar toSave putMVar toSave $ Just s -- | Repeatedly save serialized snapshots of current state. loopSave :: Binary a => COps -> (a -> FilePath) -> ChanSave a -> IO () loopSave cops stateToFileName toSave = loop where loop = do -- Wait until anyting to save. ms <- takeMVar toSave case ms of Just s -> do dataDir <- appDataDir tryCreateDir (dataDir "saves") let fileName = stateToFileName s yield -- minimize UI lag due to saving encodeEOF (dataDir "saves" fileName) (vExevLib cops, s) -- Wait until the save finished. During that time, the mvar -- is continually updated to newest state values. loop Nothing -> return () -- exit wrapInSaves :: Binary a => COps -> (a -> FilePath) -> (ChanSave a -> IO ()) -> IO () {-# INLINE wrapInSaves #-} wrapInSaves cops stateToFileName exe = do -- We don't merge this with the other calls to waitForChildren, -- because, e.g., for server, we don't want to wait for clients to exit, -- if the server crashes (but we wait for the save to finish). toSave <- newEmptyMVar a <- async $ loopSave cops stateToFileName toSave link a let fin = do -- Wait until the last save (if any) starts -- and tell the save thread to end. putMVar toSave Nothing -- Wait 0.5s to flush debug and then until the save thread ends. threadDelay 500000 wait a exe toSave `Ex.finally` fin -- The creation of, e.g., the initial client state, is outside the 'finally' -- clause, but this is OK, since no saves are ordered until 'runActionCli'. -- We save often, not only in the 'finally' section, in case of -- power outages, kill -9, GHC runtime crashes, etc. For internal game -- crashes, C-c, etc., the finalizer would be enough. -- If we implement incremental saves, saving often will help -- to spread the cost, to avoid a long pause at game exit. -- | Restore a saved game, if it exists. Initialize directory structure -- and copy over data files, if needed. restoreGame :: Binary a => COps -> FilePath -> IO (Maybe a) restoreGame cops fileName = do -- Create user data directory and copy files, if not already there. dataDir <- appDataDir tryCreateDir dataDir let path bkp = dataDir "saves" bkp <> fileName saveExists <- doesFileExist (path "") -- If the savefile exists but we get IO or decoding errors, -- we show them and start a new game. If the savefile was randomly -- corrupted or made read-only, that should solve the problem. -- OTOH, serious IO problems (e.g. failure to create a user data directory) -- terminate the program with an exception. res <- Ex.try $ if saveExists then do (vExevLib2, s) <- strictDecodeEOF (path "") if vExevLib2 == vExevLib cops then return $ Just s else do let msg = "Savefile" <+> T.pack (path "") <+> "from old version" <+> showVersion2 vExevLib2 <+> "detected while trying to restore" <+> showVersion2 (vExevLib cops) <+> "game." fail $ T.unpack msg else return Nothing let handler :: Ex.SomeException -> IO (Maybe a) handler e = do let msg = "Restore failed. The old file moved aside. The error message is:" <+> (T.unwords . T.lines) (tshow e) delayPrint msg renameFile (path "") (path "bkp.") return Nothing either handler return res vExevLib :: COps -> (Version, Version) vExevLib cops = let exeVersion = rexeVersion $ getStdRuleset cops libVersion = Self.version in (exeVersion, libVersion) showVersion2 :: (Version, Version) -> Text showVersion2 (exeVersion, libVersion) = T.pack $ showVersion exeVersion <> "-" <> showVersion libVersion delayPrint :: Text -> IO () delayPrint t = do delay <- R.randomRIO (0, 1000000) threadDelay delay -- try not to interleave saves with other clients T.hPutStrLn stdout t hFlush stdout saveNameCli :: COps -> FactionId -> String saveNameCli cops side = let gameShortName = case T.words $ rtitle $ getStdRuleset cops of w : _ -> T.unpack w _ -> "Game" n = fromEnum side -- we depend on the numbering hack to number saves in gameShortName ++ (if n > 0 then ".human_" ++ show n else ".computer_" ++ show (-n)) ++ ".sav" saveNameSer :: COps -> String saveNameSer cops = let gameShortName = case T.words $ rtitle $ getStdRuleset cops of w : _ -> T.unpack w _ -> "Game" in gameShortName ++ ".server.sav" LambdaHack-0.8.3.0/Game/LambdaHack/Server/0000755000000000000000000000000013315545734016115 5ustar0000000000000000LambdaHack-0.8.3.0/Game/LambdaHack/Server/DungeonGen.hs0000644000000000000000000002603413315545734020507 0ustar0000000000000000-- | The dungeon generation routine. It creates empty dungeons, without -- actors and without items, either lying on the floor or embedded inside tiles. module Game.LambdaHack.Server.DungeonGen ( FreshDungeon(..), dungeonGen #ifdef EXPOSE_INTERNAL -- * Internal operations , convertTileMaps, buildTileMap, buildLevel, placeDownStairs , levelFromCaveKind #endif ) where import Prelude () import Game.LambdaHack.Common.Prelude import qualified Control.Monad.Trans.State.Strict as St import qualified Data.EnumMap.Strict as EM import qualified Data.IntMap.Strict as IM import Data.Tuple import qualified System.Random as R import qualified Game.LambdaHack.Common.Dice as Dice import Game.LambdaHack.Common.Frequency import Game.LambdaHack.Common.Kind import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.Point import qualified Game.LambdaHack.Common.PointArray as PointArray import Game.LambdaHack.Common.Random import qualified Game.LambdaHack.Common.Tile as Tile import Game.LambdaHack.Common.Time import Game.LambdaHack.Content.CaveKind import Game.LambdaHack.Content.ModeKind import Game.LambdaHack.Content.PlaceKind (PlaceKind) import Game.LambdaHack.Content.TileKind (TileKind) import qualified Game.LambdaHack.Content.TileKind as TK import Game.LambdaHack.Server.DungeonGen.Cave import Game.LambdaHack.Server.DungeonGen.Place convertTileMaps :: COps -> Bool -> Rnd (ContentId TileKind) -> Maybe (Rnd (ContentId TileKind)) -> Int -> Int -> TileMapEM -> Rnd TileMap convertTileMaps COps{coTileSpeedup} areAllWalkable cdefTile mpickPassable cxsize cysize ltile = do let runCdefTile :: R.StdGen -> (ContentId TileKind, R.StdGen) runCdefTile = St.runState cdefTile runUnfold gen = let (gen1, gen2) = R.split gen in (PointArray.unfoldrNA cxsize cysize runCdefTile gen1, gen2) converted0 <- St.state runUnfold let converted1 = converted0 PointArray.// EM.assocs ltile case mpickPassable of _ | areAllWalkable -> return converted1 -- all walkable; passes OK Nothing -> return converted1 -- no walkable tiles for filling the map Just pickPassable -> do -- some tiles walkable, so ensure connectivity let passes p@Point{..} array = px >= 0 && px <= cxsize - 1 && py >= 0 && py <= cysize - 1 && Tile.isWalkable coTileSpeedup (array PointArray.! p) -- If no point blocks on both ends, then I can eventually go -- from bottom to top of the map and from left to right -- unless there are disconnected areas inside rooms). blocksHorizontal (Point x y) array = not (passes (Point (x + 1) y) array || passes (Point (x - 1) y) array) blocksVertical (Point x y) array = not (passes (Point x (y + 1)) array || passes (Point x (y - 1)) array) 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.isEasyOpen coTileSpeedup c) && n `EM.notMember` ltile && blocks n array then walkableTile else c in PointArray.imapA g array walkable2 <- pickPassable let converted2 = connect xeven blocksHorizontal walkable2 converted1 walkable3 <- pickPassable let converted3 = connect yeven blocksVertical walkable3 converted2 walkable4 <- pickPassable let converted4 = connect (not . xeven) blocksHorizontal walkable4 converted3 walkable5 <- pickPassable let converted5 = connect (not . yeven) blocksVertical walkable5 converted4 return converted5 buildTileMap :: COps -> Cave -> Rnd TileMap buildTileMap cops@COps{cotile, cocave} Cave{dkind, dmap, dnight} = do let CaveKind{cxsize, cysize, cpassable, cdefTile} = okind cocave dkind nightCond kt = not (Tile.kindHasFeature TK.Walkable kt) || (if dnight then id else not) (Tile.kindHasFeature TK.Dark kt) pickDefTile = fromMaybe (error $ "" `showFailure` cdefTile) <$> opick cotile cdefTile nightCond wcond kt = Tile.isEasyOpenKind kt && nightCond kt mpickPassable = if cpassable then Just $ fromMaybe (error $ "" `showFailure` cdefTile) <$> opick cotile cdefTile wcond else Nothing nwcond kt = not (Tile.kindHasFeature TK.Walkable kt) && nightCond kt areAllWalkable <- isNothing <$> opick cotile cdefTile nwcond convertTileMaps cops areAllWalkable pickDefTile mpickPassable cxsize cysize dmap -- Create a level from a cave. buildLevel :: COps -> Int -> GroupName CaveKind -> Int -> Dice.AbsDepth -> [Point] -> Rnd (Level, [Point]) buildLevel cops@COps{cocave} ln genName minD totalDepth lstairPrev = do dkind <- fromMaybe (error $ "" `showFailure` genName) <$> opick cocave genName (const True) let kc = okind cocave dkind -- Simple rule for now: level @ln@ has depth (difficulty) @abs ln@. ldepth = Dice.AbsDepth $ abs ln -- Any stairs coming from above are considered extra stairs -- and if they don't exceed @extraStairs@, -- the amount is filled up with single downstairs. -- If they do exceed @extraStairs@, some of them end here. extraStairs <- castDice ldepth totalDepth $ cextraStairs kc let (abandonedStairs, remainingStairsDown) = if ln == minD then (length lstairPrev, 0) else let double = min (length lstairPrev) extraStairs single = max 0 $ extraStairs - double in (length lstairPrev - double, single) (lstairsSingleUp, lstairsDouble) = splitAt abandonedStairs lstairPrev lallUpStairs = lstairsDouble ++ lstairsSingleUp freq = toFreq ("buildLevel" <+> tshow ln) $ map swap $ cstairFreq kc addSingleDown :: [(Point, GroupName PlaceKind)] -> Int -> Rnd [(Point, GroupName PlaceKind)] addSingleDown acc 0 = return acc addSingleDown acc k = do pos <- placeDownStairs kc $ lallUpStairs ++ map fst acc stairGroup <- frequency freq addSingleDown ((pos, stairGroup) : acc) (k - 1) stairsSingleDown <- addSingleDown [] remainingStairsDown let lstairsSingleDown = map fst stairsSingleDown fixedStairsDouble <- mapM (\p -> do stairGroup <- frequency freq return (p, stairGroup)) lstairsDouble fixedStairsUp <- mapM (\p -> do stairGroup <- frequency freq return (p, toGroupName $ tshow stairGroup <+> "up")) lstairsSingleUp let fixedStairsDown = map (\(p, t) -> (p, toGroupName $ tshow t <+> "down")) stairsSingleDown lallStairs = lallUpStairs ++ lstairsSingleDown fixedEscape <- case cescapeGroup kc of Nothing -> return [] Just escapeGroup -> do epos <- placeDownStairs kc lallStairs return [(epos, escapeGroup)] let lescape = map fst fixedEscape fixedCenters = EM.fromList $ fixedEscape ++ fixedStairsDouble ++ fixedStairsUp ++ fixedStairsDown posUp Point{..} = Point (px - 1) py posDn Point{..} = Point (px + 1) py lstair = ( map posUp $ lstairsSingleUp ++ lstairsDouble , map posDn $ lstairsDouble ++ lstairsSingleDown ) dsecret <- randomR (1, maxBound) cave <- buildCave cops ldepth totalDepth dsecret dkind fixedCenters cmap <- buildTileMap cops cave let lvl = levelFromCaveKind cops dkind ldepth cmap lstair lescape (dnight cave) return (lvl, lstairsDouble ++ lstairsSingleDown) -- Places yet another staircase (or escape), taking into account only -- the already existing stairs. placeDownStairs :: CaveKind -> [Point] -> Rnd Point placeDownStairs kc@CaveKind{..} ps = do let dist cmin p = all (\pos -> chessDist p pos > cmin) ps distProj p = all (\pos -> (px pos == px p || px pos > px p + 5 || px pos < px p - 5) && (py pos == py p || py pos > py p + 3 || py pos < py p - 3)) $ ps ++ bootFixedCenters kc minDist = if length ps >= 3 then 0 else cminStairDist f p@Point{..} = if p `inside` (9, 8, cxsize - 10, cysize - anchorDown - 5) then if dist minDist p && distProj p then Just p else Nothing else let nx = if | px < 9 -> 4 | px > cxsize - 10 -> cxsize - 5 | otherwise -> px ny = if | py < 8 -> 3 | py > cysize - anchorDown - 5 -> cysize - anchorDown | otherwise -> py np = Point nx ny in if dist 0 np && distProj np then Just np else Nothing findPoint cxsize cysize f -- Build rudimentary level from a cave kind. levelFromCaveKind :: COps -> ContentId CaveKind -> Dice.AbsDepth -> TileMap -> ([Point], [Point]) -> [Point] -> Bool -> Level levelFromCaveKind COps{cocave, coTileSpeedup} lkind ldepth ltile lstair lescape lnight = let f n t | Tile.isExplorable coTileSpeedup t = n + 1 | otherwise = n lexpl = PointArray.foldlA' f 0 ltile CaveKind{cxsize, cysize} = okind cocave lkind in Level { lkind , ldepth , lfloor = EM.empty , lembed = EM.empty , lactor = EM.empty , ltile , lxsize = cxsize , lysize = cysize , lsmell = EM.empty , lstair , lescape , lseen = 0 , lexpl , ltime = timeZero , lnight } -- | Freshly generated and not yet populated dungeon. data FreshDungeon = FreshDungeon { freshDungeon :: Dungeon -- ^ maps for all levels , freshTotalDepth :: Dice.AbsDepth -- ^ absolute dungeon depth } -- | Generate the dungeon for a new game. dungeonGen :: COps -> Caves -> Rnd FreshDungeon dungeonGen cops caves = do let (minD, maxD) = case (IM.minViewWithKey caves, IM.maxViewWithKey caves) of (Just ((s, _), _), Just ((e, _), _)) -> (s, e) _ -> error $ "no caves" `showFailure` caves freshTotalDepth = assert (signum minD == signum maxD) $ Dice.AbsDepth $ max 10 $ max (abs minD) (abs maxD) buildLvl :: ([(LevelId, Level)], [Point]) -> (Int, GroupName CaveKind) -> Rnd ([(LevelId, Level)], [Point]) buildLvl (l, ldown) (n, genName) = do -- lstairUp for the next level is lstairDown for the current level (lvl, ldown2) <- buildLevel cops n genName minD freshTotalDepth ldown return ((toEnum n, lvl) : l, ldown2) (levels, _) <- foldlM' buildLvl ([], []) $ reverse $ IM.assocs caves let freshDungeon = EM.fromList levels return $! FreshDungeon{..} LambdaHack-0.8.3.0/Game/LambdaHack/Server/HandleRequestM.hs0000644000000000000000000011326613315545734021343 0ustar0000000000000000-- | Semantics of requests -- . -- A couple of them do not take time, the rest does. -- Note that since the results are atomic commands, which are executed -- only later (on the server and some of the clients), all condition -- are checkd by the semantic functions in the context of the state -- before the server command. Even if one or more atomic actions -- are already issued by the point an expression is evaluated, they do not -- influence the outcome of the evaluation. module Game.LambdaHack.Server.HandleRequestM ( handleRequestAI, handleRequestUI, handleRequestTimed, switchLeader , reqMove, reqDisplace, reqAlterFail, reqGameDropAndExit, reqGameSaveAndExit #ifdef EXPOSE_INTERNAL -- * Internal operations , execFailure, setBWait, managePerRequest, handleRequestTimedCases , affectSmell, reqMelee, reqMeleeChecked, reqAlter , reqWait, reqMoveItems, reqMoveItem, computeRndTimeout, reqProject, reqApply , reqGameRestart, reqGameSave, reqTactic, reqAutomate #endif ) where import Prelude () import Game.LambdaHack.Common.Prelude import qualified Data.EnumMap.Strict as EM import qualified Data.Text as T import qualified Text.Show.Pretty as Show.Pretty import Game.LambdaHack.Atomic import Game.LambdaHack.Client (ReqAI (..), ReqUI (..), RequestTimed (..)) import 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.ItemAspect as IA import Game.LambdaHack.Common.Kind import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.MonadStateRead import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.Random import Game.LambdaHack.Common.ReqFailure import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile import Game.LambdaHack.Common.Time import Game.LambdaHack.Common.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.CommonM import Game.LambdaHack.Server.HandleEffectM import Game.LambdaHack.Server.ItemM import Game.LambdaHack.Server.MonadServer import Game.LambdaHack.Server.PeriodicM import Game.LambdaHack.Server.ServerOptions import Game.LambdaHack.Server.State execFailure :: MonadServerAtomic m => ActorId -> RequestTimed -> ReqFailure -> m () execFailure aid req failureSer = do -- Clients should rarely do that (only in case of invisible actors) -- so we report it to the client, but do not crash -- (server should work OK with stupid clients, too). body <- getsState $ getActorBody aid let fid = bfid body msg = showReqFailure failureSer impossible = impossibleReqFailure failureSer debugShow :: Show a => a -> Text debugShow = T.pack . Show.Pretty.ppShow possiblyAlarm = if impossible then debugPossiblyPrintAndExit else debugPossiblyPrint possiblyAlarm $ "execFailure:" <+> msg <> "\n" <> debugShow body <> "\n" <> debugShow req <> "\n" <> debugShow failureSer execSfxAtomic $ SfxMsgFid fid $ SfxUnexpected failureSer -- | The semantics of server commands. -- AI always takes time and so doesn't loop. handleRequestAI :: MonadServerAtomic m => ReqAI -> m (Maybe RequestTimed) handleRequestAI cmd = case cmd of ReqAITimed cmdT -> return $ Just cmdT ReqAINop -> return Nothing -- | The semantics of server commands. Only the first two cases affect time. handleRequestUI :: MonadServerAtomic m => FactionId -> ActorId -> ReqUI -> m (Maybe RequestTimed) handleRequestUI fid aid cmd = case cmd of ReqUITimed cmdT -> return $ Just cmdT ReqUIGameRestart t d -> reqGameRestart aid t d >> return Nothing ReqUIGameDropAndExit -> reqGameDropAndExit aid >> return Nothing ReqUIGameSaveAndExit -> reqGameSaveAndExit aid >> return Nothing ReqUIGameSave -> reqGameSave >> return Nothing ReqUITactic toT -> reqTactic fid toT >> return Nothing ReqUIAutomate -> reqAutomate fid >> return Nothing ReqUINop -> return Nothing -- | This is a shorthand. Instead of setting @bwait@ in @ReqWait@ -- and unsetting in all other requests, we call this once before -- executing a request. setBWait :: MonadServerAtomic m => RequestTimed -> ActorId -> Actor -> m (Maybe Bool) {-# INLINE setBWait #-} setBWait cmd aid b = do let mwait = case cmd of ReqWait -> Just True -- true wait, with bracing, no overhead, etc. ReqWait10 -> Just False -- false wait, only one clip at a time _ -> Nothing when ((mwait == Just True) /= bwait b) $ execUpdAtomic $ UpdWaitActor aid (mwait == Just True) return mwait handleRequestTimed :: MonadServerAtomic m => FactionId -> ActorId -> RequestTimed -> m Bool handleRequestTimed fid aid cmd = do b <- getsState $ getActorBody aid mwait <- setBWait cmd aid b -- Note that only the ordinary 1-turn wait eliminates overhead. -- The more fine-graned waits don't make actors braced and induce -- overhead, so that they have some drawbacks in addition to the -- benefit of seeing approaching danger up to almost a turn faster. -- It may be too late to block then, but not too late to sidestep or attack. unless (mwait == Just True) $ overheadActorTime fid (blid b) advanceTime aid (if mwait == Just False then 10 else 100) True handleRequestTimedCases aid cmd managePerRequest aid return $! isNothing mwait -- for speed, we report if @cmd@ harmless -- | Clear deltas for Calm and HP for proper UI display and AI hints. managePerRequest :: MonadServerAtomic m => ActorId -> m () managePerRequest aid = do b <- getsState $ getActorBody aid let clearMark = 0 unless (bcalmDelta b == ResDelta (0, 0) (0, 0)) $ -- Clear delta for the next player turn. execUpdAtomic $ UpdRefillCalm aid clearMark unless (bhpDelta b == ResDelta (0, 0) (0, 0)) $ -- Clear delta for the next player turn. execUpdAtomic $ UpdRefillHP aid clearMark handleRequestTimedCases :: MonadServerAtomic m => ActorId -> RequestTimed -> m () handleRequestTimedCases aid cmd = case cmd of ReqMove target -> reqMove aid target ReqMelee target iid cstore -> reqMelee aid target iid cstore ReqDisplace target -> reqDisplace aid target ReqAlter tpos -> reqAlter aid tpos ReqWait -> reqWait aid ReqWait10 -> reqWait aid -- the differences are handled elsewhere ReqMoveItems l -> reqMoveItems aid l ReqProject p eps iid cstore -> reqProject aid p eps iid cstore ReqApply iid cstore -> reqApply aid iid cstore switchLeader :: MonadServerAtomic m => FactionId -> ActorId -> m () {-# INLINE switchLeader #-} switchLeader fid aidNew = do fact <- getsState $ (EM.! fid) . sfactionD bPre <- getsState $ getActorBody aidNew let mleader = gleader fact !_A1 = assert (Just aidNew /= mleader && not (bproj bPre) `blame` (aidNew, bPre, fid, fact)) () !_A2 = assert (bfid bPre == fid `blame` "client tries to move other faction actors" `swith` (aidNew, bPre, fid, fact)) () let (autoDun, _) = autoDungeonLevel fact arena <- case mleader of Nothing -> return $! blid bPre Just leader -> do b <- getsState $ getActorBody leader return $! blid b if | blid bPre /= arena && autoDun -> execFailure aidNew ReqWait{-hack-} NoChangeDunLeader | otherwise -> do execUpdAtomic $ UpdLeadFaction fid mleader (Just aidNew) -- We exchange times of the old and new leader. -- This permits an abuse, because a slow tank can be moved fast -- by alternating between it and many fast actors (until all of them -- get slowed down by this and none remain). But at least the sum -- of all times of a faction is conserved. And we avoid double moves -- against the UI player caused by his leader changes. There may still -- happen double moves caused by AI leader changes, but that's rare. -- The flip side is the possibility of multi-moves of the UI player -- as in the case of the tank. -- Warning: when the action is performed on the server, -- the time of the actor is different than when client prepared that -- action, so any client checks involving time should discount this. case mleader of Just aidOld | aidOld /= aidNew -> swapTime aidOld aidNew _ -> return () -- * ReqMove -- | Add a smell trace for the actor to the level. For now, only actors -- with gender leave strong and unique enough smell. If smell already there -- and the actor can smell, remove smell. Projectiles are ignored. -- As long as an actor can smell, he doesn't leave any smell ever. affectSmell :: MonadServerAtomic m => ActorId -> m () affectSmell aid = do b <- getsState $ getActorBody aid unless (bproj b) $ do fact <- getsState $ (EM.! bfid b) . sfactionD ar <- getsState $ getActorAspect aid let smellRadius = IA.aSmell ar when (fhasGender (gplayer fact) || smellRadius > 0) $ do localTime <- getsState $ getLocalTime $ blid b lvl <- getLevel $ blid b let oldS = fromMaybe timeZero $ EM.lookup (bpos b) . lsmell $ lvl newTime = timeShift localTime smellTimeout newS = if smellRadius > 0 then timeZero else newTime when (oldS /= newS) $ execUpdAtomic $ UpdAlterSmell (blid b) (bpos b) oldS newS -- | Actor moves or attacks. -- Note that client may not be able to see an invisible monster -- so it's the server that determines if melee took place, etc. -- Also, only the server is authorized to check if a move is legal -- and it needs full context for that, e.g., the initial actor position -- to check if melee attack does not try to reach to a distant tile. reqMove :: MonadServerAtomic m => ActorId -> Vector -> m () reqMove source dir = do COps{coTileSpeedup} <- getsState scops actorSk <- currentSkillsServer source sb <- getsState $ getActorBody source let abInSkill ab = isJust (btrajectory sb) || EM.findWithDefault 0 ab actorSk > 0 lid = blid sb lvl <- getLevel lid let spos = bpos sb -- source position tpos = spos `shift` dir -- target position -- This predicate is symmetric wrt source and target, though the effect -- of collision may not be (the source projectiles applies its effect -- on the target particles, but loses 1 HP due to the collision). -- The condision implies that it's impossible to shoot down a bullet -- with a bullet, but a bullet can shoot down a burstable target, -- as well as be swept away by it, and two burstable projectiles -- burst when meeting mid-air. Projectiles that are not bursting -- nor damaging never collide with any projectile. collides <- getsState $ \s tb -> let sitemKind = getIidKindServer (btrunk sb) s titemKind = getIidKindServer (btrunk tb) s -- Such projectiles are prone to bursitng or are themselves -- particles of an explosion shockwave. bursting itemKind = IK.Fragile `elem` IK.ifeature itemKind && IK.Lobable `elem` IK.ifeature itemKind sbursting = bursting sitemKind tbursting = bursting titemKind -- Such projectiles, even if not bursting themselves, can cause -- another projectile to burst. damaging itemKind = IK.idamage itemKind /= 0 sdamaging = damaging sitemKind tdamaging = damaging titemKind -- Avoid explosion extinguishing itself via its own particles colliding. sameBlast = IK.isBlast sitemKind && getIidKindIdServer (btrunk sb) s == getIidKindIdServer (btrunk tb) s in not sameBlast && (sbursting && (tdamaging || tbursting) || (tbursting && (sdamaging || sbursting))) -- We start by checking actors at the target position. tgt <- getsState $ posToAssocs tpos lid case tgt of (target, tb) : _ | not (bproj sb) || not (bproj tb) || collides tb -> do -- A projectile is too small and insubstantial to hit another projectile, -- unless it's large enough or tends to explode (fragile and lobable). -- The actor in the way is visible or not; server sees him always. -- Below the only weapon (the only item) of projectiles is picked. mweapon <- pickWeaponServer source case mweapon of Just (wp, cstore) | abInSkill Ability.AbMelee -> reqMeleeChecked source target wp cstore _ -> return () -- waiting, even if no @AbWait@ ability _ -> do -- Either the position is empty, or all involved actors are proj. -- Movement requires full access and skill. if Tile.isWalkable coTileSpeedup $ lvl `at` tpos then if abInSkill Ability.AbMove then do execUpdAtomic $ UpdMoveActor source spos tpos affectSmell source else execFailure source (ReqMove dir) MoveUnskilled else -- Client foolishly tries to move into unwalkable tile. execFailure source (ReqMove dir) MoveNothing -- * ReqMelee -- | Resolves the result of an actor moving into another. -- Actors on unwalkable positions can be attacked without any restrictions. -- For instance, an actor embedded in a wall can be attacked from -- an adjacent position. This function is analogous to projectGroupItem, -- but for melee and not using up the weapon. -- No problem if there are many projectiles at the spot. We just -- attack the one specified. reqMelee :: MonadServerAtomic m => ActorId -> ActorId -> ItemId -> CStore -> m () reqMelee source target iid cstore = do actorSk <- currentSkillsServer source if EM.findWithDefault 0 Ability.AbMelee actorSk > 0 then reqMeleeChecked source target iid cstore else execFailure source (ReqMelee target iid cstore) MeleeUnskilled reqMeleeChecked :: MonadServerAtomic m => ActorId -> ActorId -> ItemId -> CStore -> m () reqMeleeChecked source target iid cstore = do sb <- getsState $ getActorBody source tb <- getsState $ getActorBody target let req = ReqMelee target iid cstore if source == target then execFailure source req MeleeSelf else if not (checkAdjacent sb tb) then execFailure source req MeleeDistant else do let sfid = bfid sb tfid = bfid tb -- Let the missile drop down, but don't remove its trajectory -- so that it doesn't pretend to have hit a wall. haltProjectile aid b = case btrajectory b of btra@(Just (l, speed)) | not $ null l -> execUpdAtomic $ UpdTrajectory aid btra $ Just ([], speed) _ -> return () sfact <- getsState $ (EM.! sfid) . sfactionD itemKind <- getsState $ getIidKindServer $ btrunk tb -- Only catch with appendages, never with weapons. Never steal trunk -- from an already caught projectile or one with many items inside. if bproj tb && EM.size (beqp tb) == 1 && not (IK.isBlast itemKind) && cstore == COrgan then do -- Catching the projectile, that is, stealing the item from its eqp. -- No effect from our weapon (organ) is applied to the projectile -- and the weapon (organ) is never destroyed, even if not durable. -- Pushed actor doesn't stop flight by catching the projectile -- nor does he lose 1HP. -- This is not overpowered, because usually at least one partial wait -- is needed to sync (if not, attacker should switch missiles) -- and so only every other missile can be caught. Normal sidestepping -- or sync and displace, if in a corridor, is as effective -- and blocking can be even more so, depending on stats of the missile. -- Missiles are really easy to defend against, but sight (and so, Calm) -- is the key, as well as light, ambush around a corner, etc. execSfxAtomic $ SfxSteal source target iid cstore case EM.assocs $ beqp tb of [(iid2, (k, _))] -> do upds <- generalMoveItem True iid2 k (CActor target CEqp) (CActor source CInv) mapM_ execUpdAtomic upds itemFull <- getsState $ itemToFull iid2 discoverIfMinorEffects (CActor source CInv) iid2 (itemKindId itemFull) err -> error $ "" `showFailure` err haltProjectile target tb else do if bproj sb && bproj tb then do -- Special case for collision of projectiles, because they just -- symmetrically ram into each other, so picking one to hit another, -- based on random timing, would be wrong. -- Instead of suffering melee attack, let the target projectile -- get smashed and burst (if fragile and if not piercing). -- The source projectile terminates flight (unless pierces) later on. when (bhp tb > oneM) $ execUpdAtomic $ UpdRefillHP target minusM when (bhp tb <= oneM) $ -- If projectile has too low HP to pierce, terminate its flight. haltProjectile target tb else do -- Normal hit, with effects. Msgs inside @SfxStrike@ describe -- the source part of the strike. execSfxAtomic $ SfxStrike source target iid cstore let c = CActor source cstore -- Msgs inside @itemEffect@ describe the target part of the strike. -- If any effects and aspects, this is also where they are identified. -- Here also the melee damage is applied, before any effects are. meleeEffectAndDestroy source target iid c sb2 <- getsState $ getActorBody source case btrajectory sb2 of Just (tra, _speed) | not (null tra) -> do -- Deduct a hitpoint for a pierce of a projectile -- or due to a hurled actor colliding with another. -- Don't deduct if no pierce, to prevent spam. -- Never kill in this way. when (bhp sb2 > oneM) $ do execUpdAtomic $ UpdRefillHP source minusM unless (bproj sb2) $ do execSfxAtomic $ SfxMsgFid (bfid sb2) $ SfxCollideActor (blid tb) source target unless (bproj tb) $ execSfxAtomic $ SfxMsgFid (bfid tb) $ SfxCollideActor (blid tb) source target when (not (bproj sb2) || bhp sb2 <= oneM) $ -- Non-projectiles can't pierce, so terminate their flight. -- If projectile has too low HP to pierce, ditto. haltProjectile source sb2 _ -> return () -- 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 sb2 || bproj tb fromDipl = EM.findWithDefault Unknown tfid (gdipl sfact) unless (friendlyFire || isFoe sfid sfact tfid -- already at war || isFriend sfid sfact tfid) $ -- allies never at war execUpdAtomic $ UpdDiplFaction sfid tfid fromDipl War -- * ReqDisplace -- | Actor tries to swap positions with another. reqDisplace :: MonadServerAtomic m => ActorId -> ActorId -> m () reqDisplace source target = do COps{coTileSpeedup} <- getsState scops actorSk <- currentSkillsServer source sb <- getsState $ getActorBody source let abInSkill ab = isJust (btrajectory sb) || EM.findWithDefault 0 ab actorSk > 0 tb <- getsState $ getActorBody target tfact <- getsState $ (EM.! bfid tb) . sfactionD let tpos = bpos tb atWar = isFoe (bfid tb) tfact (bfid sb) req = ReqDisplace target ar <- getsState $ getActorAspect target dEnemy <- getsState $ dispEnemy source target $ IA.aSkills ar if | not (abInSkill Ability.AbDisplace) -> execFailure source req DisplaceUnskilled | not (checkAdjacent sb tb) -> execFailure source req DisplaceDistant | atWar && not dEnemy -> do -- if not at war, can displace always -- We don't fail with DisplaceImmobile and DisplaceSupported. -- because it's quite common they can't be determined by the attacker, -- and so the failure would be too alarming to the player. -- If the character melees instead, the player can tell displace failed. -- As for the other failures, they are impossible and we don't -- verify here that they don't occur, for simplicity. mweapon <- pickWeaponServer source case mweapon of Just (wp, cstore) | abInSkill Ability.AbMelee -> reqMeleeChecked source target wp cstore _ -> return () -- waiting, even if no @AbWait@ ability | otherwise -> do let lid = blid sb lvl <- getLevel lid -- Displacing requires full access. if Tile.isWalkable coTileSpeedup $ lvl `at` tpos then case posToAidsLvl tpos lvl of [] -> error $ "" `showFailure` (source, sb, target, tb) [_] -> do execUpdAtomic $ UpdDisplaceActor source target -- We leave or wipe out smell, for consistency, but it's not -- absolute consistency, e.g., blinking doesn't touch smell, -- so sometimes smellers will backtrack once to wipe smell. OK. affectSmell source affectSmell target _ -> 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. reqAlter :: MonadServerAtomic m => ActorId -> Point -> m () reqAlter source tpos = do mfail <- reqAlterFail source tpos let req = ReqAlter tpos maybe (return ()) (execFailure source req) mfail reqAlterFail :: MonadServerAtomic m => ActorId -> Point -> m (Maybe ReqFailure) reqAlterFail source tpos = do COps{cotile, coTileSpeedup} <- getsState scops sb <- getsState $ getActorBody source ar <- getsState $ getActorAspect source let calmE = calmEnough sb ar lid = blid sb sClient <- getsServer $ (EM.! bfid sb) . sclientStates itemToF <- getsState $ flip itemToFull actorSk <- currentSkillsServer source localTime <- getsState $ getLocalTime lid let alterSkill = EM.findWithDefault 0 Ability.AbAlter actorSk applySkill = EM.findWithDefault 0 Ability.AbApply actorSk embeds <- getsState $ getEmbedBag lid tpos lvl <- getLevel lid let serverTile = lvl `at` tpos lvlClient = (EM.! lid) . sdungeon $ sClient clientTile = lvlClient `at` tpos hiddenTile = Tile.hideAs cotile serverTile revealEmbeds = unless (EM.null embeds) $ do s <- getState let ais = map (\iid -> (iid, getItemBody iid s)) (EM.keys embeds) execUpdAtomic $ UpdSpotItemBag (CEmbed lid tpos) embeds ais tryApplyEmbeds = do -- Can't send @SfxTrigger@ afterwards, because actor may be moved -- by the embeds to another level, where @tpos@ is meaningless. execSfxAtomic $ SfxTrigger source tpos mapM_ tryApplyEmbed $ EM.assocs embeds tryApplyEmbed (iid, kit) = do let itemFull@ItemFull{itemKind} = itemToF iid legal = permittedApply localTime applySkill calmE itemFull kit -- Let even completely unskilled actors trigger basic embeds. case legal of Left ApplyNoEffects -> return () -- pure flavour embed Left reqFail | reqFail `notElem` [ApplyUnskilled, NotCalmPrecious] -> -- The failure is fully expected, because client may choose -- to trigger some embeds, knowing that others won't fire. execSfxAtomic $ SfxMsgFid (bfid sb) $ SfxExpected ("embedded" <+> IK.iname itemKind) reqFail _ -> itemEffectEmbedded source lid tpos iid if chessDist tpos (bpos sb) > 1 then return $ Just AlterDistant else if Just clientTile == hiddenTile then -- searches -- Only actors with AbAlter > 1 can search for hidden doors, etc. if alterSkill <= 1 then return $ Just AlterUnskilled -- don't leak about searching else do -- Blocking by items nor actors does not prevent searching. -- Searching broadcasted, in case actors from other factions are present -- so that they can learn the tile and learn our action. -- If they already know the tile, they will just consider our action -- a waste of time and ignore the command. execUpdAtomic $ UpdSearchTile source tpos serverTile -- Searching also reveals the embedded items of the tile. -- If the items are already seen by the client -- (e.g., due to item detection, despite tile being still hidden), -- the command is ignored on the client. revealEmbeds -- Seaching triggers the embeds as well, after they are revealed. -- The rationale is that the items were all the time present -- (just invisible to the client), so they need to be triggered. -- The exception is changable tiles, because they are not so easy -- to trigger; they need subsequent altering. unless (Tile.isDoor coTileSpeedup serverTile || Tile.isChangable coTileSpeedup serverTile) tryApplyEmbeds return Nothing -- success else if clientTile == serverTile then -- alters if alterSkill < Tile.alterMinSkill coTileSpeedup serverTile then return $ Just AlterUnskilled -- don't leak about altering else do let changeTo tgroup = do lvl2 <- getLevel lid -- No @SfxAlter@, because the effect is obvious (e.g., opened door). let nightCond kt = not (Tile.kindHasFeature TK.Walkable kt && Tile.kindHasFeature TK.Clear kt) || (if lnight lvl2 then id else not) (Tile.kindHasFeature TK.Dark kt) -- Sometimes the tile is determined precisely by the ambient light -- of the source tiles. If not, default to cave day/night condition. mtoTile <- rndToAction $ opick cotile tgroup nightCond toTile <- maybe (rndToAction $ fromMaybe (error $ "" `showFailure` tgroup) <$> opick cotile tgroup (const True)) return mtoTile unless (toTile == serverTile) $ do -- don't regenerate same tile -- At most one of these two will be accepted on any given client. execUpdAtomic $ UpdAlterTile lid tpos serverTile toTile -- This case happens when a client does not see a searching -- action by another faction, but sees the subsequent altering. case hiddenTile of Just tHidden -> execUpdAtomic $ UpdAlterTile lid tpos tHidden toTile Nothing -> return () case (Tile.isExplorable coTileSpeedup serverTile, Tile.isExplorable coTileSpeedup toTile) of (False, True) -> execUpdAtomic $ UpdAlterExplorable lid 1 (True, False) -> execUpdAtomic $ UpdAlterExplorable lid (-1) _ -> return () -- At the end we replace old embeds (even if partially used up) -- with new ones. -- If the source tile was hidden, the items could not be visible -- on a client, in which case the command would be ignored -- on the client, without causing any problems. Otherwise, -- if the position is in view, client has accurate info. case EM.lookup tpos (lembed lvl2) of Just bag -> do s <- getState let ais = map (\iid -> (iid, getItemBody iid s)) (EM.keys bag) execUpdAtomic $ UpdLoseItemBag (CEmbed lid tpos) bag ais Nothing -> return () -- Altering always reveals the outcome tile, so it's not hidden -- and so its embedded items are always visible. embedItem lid tpos toTile feats = TK.tfeature $ okind cotile serverTile 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 if null groupsToAlterTo && EM.null embeds then return $ Just AlterNothing -- no altering possible; silly client else if EM.notMember tpos $ lfloor lvl then if null (posToAidsLvl tpos lvl) then do -- The embeds of the initial tile are activated before the tile -- is altered. This prevents, e.g., trying to activate items -- where none are present any more, or very different to what -- the client expected. Surprise only comes through searching above. -- The items are first revealed for the sake of clients that -- may see the tile as hidden. Note that the tile is not revealed -- (unless it's altered later on, in which case the new one is). revealEmbeds tryApplyEmbeds case groupsToAlterTo of [] -> return () [groupToAlterTo] -> changeTo groupToAlterTo l -> error $ "tile changeable in many ways" `showFailure` l return Nothing -- success else return $ Just AlterBlockActor else return $ Just AlterBlockItem else -- client is misguided re tile at that position, so bail out return $ Just AlterNothing -- * ReqWait -- | Do nothing. -- -- Something is sometimes done in 'setBWait'. reqWait :: MonadServerAtomic m => ActorId -> m () {-# INLINE reqWait #-} reqWait source = do actorSk <- currentSkillsServer source unless (EM.findWithDefault 0 Ability.AbWait actorSk > 0) $ execFailure source ReqWait WaitUnskilled -- * ReqMoveItems reqMoveItems :: MonadServerAtomic m => ActorId -> [(ItemId, Int, CStore, CStore)] -> m () reqMoveItems source l = do actorSk <- currentSkillsServer source if EM.findWithDefault 0 Ability.AbMoveItem actorSk > 0 then do b <- getsState $ getActorBody source ar <- getsState $ getActorAspect source -- Server accepts item movement based on calm at the start, not end -- or in the middle, to avoid interrupted or partially ignored commands. let calmE = calmEnough b ar mapM_ (reqMoveItem source calmE) l else execFailure source (ReqMoveItems l) MoveItemUnskilled reqMoveItem :: MonadServerAtomic 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 req = ReqMoveItems [(iid, k, fromCStore, toCStore)] toC <- case toCStore of CGround -> pickDroppable aid b _ -> return $! CActor aid toCStore bagBefore <- getsState $ getContainerBag toC if | k < 1 || fromCStore == toCStore -> execFailure aid req ItemNothing | toCStore == CEqp && eqpOverfull b k -> execFailure aid req EqpOverfull | (fromCStore == CSha || toCStore == CSha) && not calmE -> execFailure aid req ItemNotCalm | otherwise -> do upds <- generalMoveItem True iid k fromC toC mapM_ execUpdAtomic upds itemFull <- getsState $ itemToFull iid when (fromCStore == CGround) $ -- pick up discoverIfMinorEffects toC iid (itemKindId itemFull) -- Reset timeout for equipped periodic items and also for items -- moved out of the shared stash, in which timeouts are not consistently -- wrt some local time, because actors from many levels put items there -- all the time (and don't rebase it to any common clock). -- If wrong local time in shared stash causes an item to recharge -- for a very long time, the player can reset it by moving it to pack -- and back to stash (as a flip side, a charging item in stash may sometimes -- be used at once on another level, with different local time, but only -- once, because after first use, the timeout is set to local time). when (toCStore `elem` [CEqp, COrgan] && fromCStore `notElem` [CEqp, COrgan] || fromCStore == CSha) $ do localTime <- getsState $ getLocalTime (blid b) -- The first recharging period after pick up is random, -- between 1 and 2 standard timeouts of the item. mrndTimeout <- rndToAction $ computeRndTimeout localTime itemFull 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 $ getContainerBag toC let afterIt = case iid `EM.lookup` bagAfter of Nothing -> error $ "" `showFailure` (iid, bagAfter, toC) Just (_, it2) -> it2 resetIt = beforeIt ++ replicate k rndT when (afterIt /= resetIt) $ execUpdAtomic $ UpdTimeItem iid toC afterIt resetIt Nothing -> return () -- no Periodic or Timeout aspect; don't touch computeRndTimeout :: Time -> ItemFull -> Rnd (Maybe Time) computeRndTimeout localTime ItemFull{itemKind, itemDisco} = case IA.aTimeout $ itemAspect itemDisco of t | t /= 0 && IK.Periodic `elem` IK.ifeature itemKind -> do rndT <- randomR (0, t) let rndTurns = timeDeltaScale (Delta timeTurn) (t + rndT) return $ Just $ timeShift localTime rndTurns _ -> return Nothing -- * ReqProject reqProject :: MonadServerAtomic m => ActorId -- ^ actor projecting the item (is on current lvl) -> Point -- ^ target position of the projectile -> Int -- ^ digital line parameter -> ItemId -- ^ the item to be projected -> CStore -- ^ 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 ar <- getsState $ getActorAspect source let calmE = calmEnough b ar if cstore == CSha && not calmE then execFailure source req ItemNotCalm else do mfail <- projectFail source tpxy eps False iid cstore False maybe (return ()) (execFailure source req) mfail -- * ReqApply reqApply :: MonadServerAtomic m => ActorId -- ^ actor applying the item (is on current level) -> ItemId -- ^ the item to be applied -> CStore -- ^ the location of the item -> m () reqApply aid iid cstore = do let req = ReqApply iid cstore b <- getsState $ getActorBody aid ar <- getsState $ getActorAspect aid let calmE = calmEnough b ar if cstore == CSha && not calmE then execFailure aid req ItemNotCalm else do bag <- getsState $ getBodyStoreBag b cstore case EM.lookup iid bag of Nothing -> execFailure aid req ApplyOutOfReach Just kit -> do itemFull <- getsState $ itemToFull iid actorSk <- currentSkillsServer aid localTime <- getsState $ getLocalTime (blid b) let skill = EM.findWithDefault 0 Ability.AbApply actorSk legal = permittedApply localTime skill calmE itemFull kit case legal of Left reqFail -> execFailure aid req reqFail Right _ -> applyItem aid iid cstore -- * ReqGameRestart reqGameRestart :: MonadServerAtomic m => ActorId -> GroupName ModeKind -> Challenge -> m () reqGameRestart aid groupName scurChalSer = do modifyServer $ \ser -> ser {soptionsNxt = (soptionsNxt ser) {scurChalSer}} b <- getsState $ getActorBody aid oldSt <- getsState $ gquit . (EM.! bfid b) . sfactionD -- We don't save game and don't wait for clips end. ASAP. modifyServer $ \ser -> ser {sbreakASAP = True} isNoConfirms <- isNoConfirmsGame -- This call to `revealItems` is really needed, because the other -- happens only at game conclusion, not at quitting. unless isNoConfirms $ revealItems Nothing execUpdAtomic $ UpdQuitFaction (bfid b) oldSt $ Just $ Status Restart (fromEnum $ blid b) (Just groupName) -- * ReqGameDropAndExit -- After we break out of the game loop, we will notice from @Camping@ -- we shouldn exit the game. reqGameDropAndExit :: MonadServerAtomic m => ActorId -> m () reqGameDropAndExit aid = do b <- getsState $ getActorBody aid oldSt <- getsState $ gquit . (EM.! bfid b) . sfactionD modifyServer $ \ser -> ser {sbreakLoop = True} execUpdAtomic $ UpdQuitFaction (bfid b) oldSt $ Just $ Status Camping (fromEnum $ blid b) Nothing -- * ReqGameSaveAndExit -- After we break out of the game loop, we will notice from @Camping@ -- we shouldn exit the game. reqGameSaveAndExit :: MonadServerAtomic m => ActorId -> m () reqGameSaveAndExit aid = do b <- getsState $ getActorBody aid oldSt <- getsState $ gquit . (EM.! bfid b) . sfactionD modifyServer $ \ser -> ser { sbreakASAP = True , swriteSave = True } execUpdAtomic $ UpdQuitFaction (bfid b) oldSt $ Just $ Status Camping (fromEnum $ blid b) Nothing -- * ReqGameSave -- After we break out of the game loop, we will notice we shouldn't quit -- the game and we will enter the game loop again. reqGameSave :: MonadServer m => m () reqGameSave = modifyServer $ \ser -> ser { sbreakASAP = True , swriteSave = True } -- * ReqTactic reqTactic :: MonadServerAtomic m => FactionId -> Tactic -> m () reqTactic fid toT = do fromT <- getsState $ ftactic . gplayer . (EM.! fid) . sfactionD execUpdAtomic $ UpdTacticFaction fid toT fromT -- * ReqAutomate reqAutomate :: MonadServerAtomic m => FactionId -> m () reqAutomate fid = execUpdAtomic $ UpdAutoFaction fid True LambdaHack-0.8.3.0/Game/LambdaHack/Server/LoopM.hs0000644000000000000000000006074613315545734017514 0ustar0000000000000000-- | The main loop of the server, processing human and computer player -- moves turn by turn. module Game.LambdaHack.Server.LoopM ( loopSer #ifdef EXPOSE_INTERNAL -- * Internal operations , factionArena, arenasForLoop, handleFidUpd, loopUpd, endClip , manageCalmAndDomination, applyPeriodicLevel , handleTrajectories, hTrajectories, setTrajectory , handleActors, hActors, restartGame #endif ) where import Prelude () import Game.LambdaHack.Common.Prelude import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES import qualified Data.Ord as Ord import Game.LambdaHack.Atomic import Game.LambdaHack.Client (ReqUI (..)) import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.Item import Game.LambdaHack.Common.Kind import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.MonadStateRead import Game.LambdaHack.Common.Perception import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile import Game.LambdaHack.Common.Time import Game.LambdaHack.Common.Vector import qualified Game.LambdaHack.Content.ItemKind as IK import Game.LambdaHack.Content.ModeKind import Game.LambdaHack.Content.RuleKind import Game.LambdaHack.Server.CommonM import Game.LambdaHack.Server.EndM import Game.LambdaHack.Server.HandleEffectM import Game.LambdaHack.Server.HandleRequestM import Game.LambdaHack.Server.MonadServer import Game.LambdaHack.Server.PeriodicM import Game.LambdaHack.Server.ProtocolM import Game.LambdaHack.Server.ServerOptions import Game.LambdaHack.Server.StartM import Game.LambdaHack.Server.State -- | Start a game session, including the clients, and then loop, -- communicating with the clients. -- -- The loop is started in server state that is empty, see 'emptyStateServer'. loopSer :: (MonadServerAtomic m, MonadServerComm m) => ServerOptions -- ^ player-supplied server options -> (Bool -> FactionId -> ChanServer -> IO ()) -- ^ function that initializes a client and runs its main loop -> m () loopSer serverOptions executorClient = do -- Recover states and launch clients. modifyServer $ \ser -> ser { soptionsNxt = serverOptions , soptions = serverOptions } cops <- getsState scops let updConn = updateConn executorClient restored <- tryRestore case restored of Just (sRaw, ser) | not $ snewGameSer serverOptions -> do -- a restored game execUpdAtomic $ UpdResumeServer $ updateCOpsAndCachedData (const cops) sRaw putServer ser {soptionsNxt = serverOptions} applyDebug factionD <- getsState sfactionD let f fid = let cmd = UpdResumeServer $ updateCOpsAndCachedData (const cops) $ sclientStates ser EM.! fid in execUpdAtomicFidCatch fid cmd mapM_ f $ EM.keys factionD updConn initPer pers <- getsServer sperFid let clear = const emptyPer persFid fid | sknowEvents serverOptions = EM.map clear (pers EM.! fid) | otherwise = pers EM.! fid mapM_ (\fid -> sendUpdate fid $ UpdResume fid (persFid fid)) (EM.keys factionD) -- We dump RNG seeds here, based on @soptionsNxt@, in case the game -- wasn't run with @--dumpInitRngs@ previously, but we need the seeds, -- e.g., to diagnose a crash. rngs <- getsServer srngs when (sdumpInitRngs serverOptions) $ dumpRngs rngs _ -> do -- starting new game for this savefile (--newGame or fresh save) s <- gameReset serverOptions Nothing Nothing -- get RNG from item boost -- Set up commandline options. let optionsBarRngs = serverOptions {sdungeonRng = Nothing, smainRng = Nothing} modifyServer $ \ser -> ser { soptionsNxt = optionsBarRngs , soptions = optionsBarRngs } execUpdAtomic $ UpdRestartServer s updConn initPer reinitGame writeSaveAll False loopUpd updConn factionArena :: MonadStateRead m => Faction -> m (Maybe LevelId) factionArena fact = case gleader fact of -- Even spawners need an active arena for their leader, -- or they start clogging stairs. Just leader -> do b <- getsState $ getActorBody leader return $ Just $ blid b Nothing -> if fleaderMode (gplayer fact) == LeaderNull || EM.null (gvictims fact) -- not in-between spawns then return Nothing else Just <$> getEntryArena fact arenasForLoop :: MonadStateRead m => m [LevelId] {-# INLINE arenasForLoop #-} arenasForLoop = do factionD <- getsState sfactionD marenas <- mapM factionArena $ EM.elems factionD let arenas = ES.toList $ ES.fromList $ catMaybes marenas !_A = assert (not (null arenas) `blame` "game over not caught earlier" `swith` factionD) () return $! arenas handleFidUpd :: (MonadServerAtomic m, MonadServerComm m) => (FactionId -> m ()) -> FactionId -> Faction -> m () {-# INLINE handleFidUpd #-} handleFidUpd updatePerFid fid fact = do -- Update perception on all levels at once, -- in case a leader is changed to actor on another -- (possibly not even currently active) level. -- This runs for all factions even if save is requested by UI. -- Let players ponder new game state while the engine is busy saving. -- Also, this ensures perception before game save is exactly the same -- as at game resume, which is an invariant we check elsewhere. updatePerFid fid -- Move a single actor only. Bail out if immediate loop break requested by UI. let handle [] = return () handle (lid : rest) = do breakASAP <- getsServer sbreakASAP unless breakASAP $ do nonWaitMove <- handleActors lid fid unless nonWaitMove $ handle rest -- Start on arena with leader, if available. fa <- factionArena fact arenas <- getsServer sarenas let myArenas = case fa of Just myArena -> myArena : delete myArena arenas Nothing -> arenas handle myArenas -- | Handle a clip (the smallest fraction of a game turn for which a frame may -- potentially be generated). Run the leader and other actors moves. -- Eventually advance the time and repeat. loopUpd :: forall m. (MonadServerAtomic m, MonadServerComm m) => m () -> m () loopUpd updConn = do let updatePerFid :: FactionId -> m () {-# NOINLINE updatePerFid #-} updatePerFid fid = do -- {-# SCC updatePerFid #-} do perValid <- getsServer $ (EM.! fid) . sperValidFid mapM_ (\(lid, valid) -> unless valid $ updatePer fid lid) (EM.assocs perValid) handleFid :: (FactionId, Faction) -> m () {-# NOINLINE handleFid #-} handleFid (fid, fact) = handleFidUpd updatePerFid fid fact loopConditionally = do factionD <- getsState sfactionD -- Update perception one last time to satisfy save/resume assertions. mapM_ updatePerFid (EM.keys factionD) modifyServer $ \ser -> ser { sbreakLoop = False , sbreakASAP = False } endOrLoop loopUpdConn (restartGame updConn loopUpdConn) loopUpdConn = do factionD <- getsState sfactionD -- Start handling actors with the single UI faction (positive ID), -- to safely save/exit. Note that this hack fails if there are many UI -- factions (when we reenable multiplayer). Then players will request -- save&exit and others will vote on it and it will happen -- after the clip has ended, not at the start. mapM_ handleFid $ EM.toDescList factionD breakASAP <- getsServer sbreakASAP breakLoop <- getsServer sbreakLoop if breakASAP || breakLoop then loopConditionally else do -- Projectiles are processed last and not at all if the UI leader -- decides to save or exit or restart or if there is game over. -- This and UI leader acting before any other ordinary actors -- ensures state is not changed and so the clip doesn't need -- to be carried through before save. arenas <- getsServer sarenas mapM_ (\fid -> mapM_ (`handleTrajectories` fid) arenas) (EM.keys factionD) endClip updatePerFid -- must be last, in case performs a bkp save -- The condition can be changed in @handleTrajectories@ by pushing -- onto an escape and in @endClip@. breakLoop2 <- getsServer sbreakLoop if breakLoop2 then loopConditionally else loopUpdConn -- process next iteration unconditionally loopUpdConn -- | Handle the end of every clip. Do whatever has to be done -- every fixed number of clips, e.g., monster generation. -- Advance time. Perform periodic saves, if applicable. -- -- This is never run if UI requested save or exit or restart and it's correct, -- because we know nobody moved and no time was or needs to be advanced -- and arenas are not changed. After game was saved and exited, -- on game resume the first clip is performed with empty arenas, -- so arena time is not updated and nobody moves, nor anything happens, -- but arenas are here correctly updated. endClip :: forall m. MonadServerAtomic m => (FactionId -> m ()) -> m () {-# INLINE endClip #-} endClip updatePerFid = do cops <- getsState scops let rules = getStdRuleset cops time <- getsState stime let clipN = time `timeFit` timeClip clipInTurn = let r = timeTurn `timeFit` timeClip in assert (r >= 5) r -- No check if @sbreakASAP@ is set, because then the function is not called. breakLoop <- getsServer sbreakLoop -- We don't send a lot of useless info to the client if the game has already -- ended. At best wasteful, at worst the player sees strange messages. unless breakLoop $ do -- I need to send time updates, because I can't add time to each command, -- because I'd need to send also all arenas, which should be updated, -- and this is too expensive data for each, e.g., projectile move. -- I send even if nothing changes so that UI time display can progress. -- Possibly @arenas@ are invalid here, but all moves were performed -- according to this value, so time should be replenished according -- to this value as well. -- This is crucial, because tiny time discrepancies can accumulate -- magnified by hunders of actors that share the clip slots due to the -- restriction that at most one faction member acts each clip. arenas <- getsServer sarenas execUpdAtomic $ UpdAgeGame arenas -- Perform periodic dungeon maintenance. when (clipN `mod` rleadLevelClips rules == 0) leadLevelSwitch let clipMod = clipN `mod` clipInTurn if | clipMod == clipInTurn - 1 -> -- Periodic activation only once per turn, for speed, -- but on all active arenas. Calm updates and domination -- happen there as well. applyPeriodicLevel | clipMod == 2 -> -- Add monsters each turn, not each clip. unless (null arenas) spawnMonster | otherwise -> return () -- @applyPeriodicLevel@ might have, e.g., dominated actors, ending the game. -- It could not have unended the game, though. breakLoop2 <- getsServer sbreakLoop unless breakLoop2 $ do -- Possibly a leader change due to @leadLevelSwitch@, so update arenas here -- for 100% accuracy at least at the start of actor moves, before they -- change leaders as part of their moves. -- -- After game resume, this is the first non-vacuus computation. -- Next call to @loopUpdConn@ really moves actors and updates arena times -- so we start in exactly the same place that UI save ended in. validArenas <- getsServer svalidArenas unless validArenas $ do arenasNew <- arenasForLoop modifyServer $ \ser -> ser {sarenas = arenasNew, svalidArenas = True} -- Update all perception for visual feedback and to make sure saving -- and resuming game doesn't affect gameplay (by updating perception). -- Perception updates in @handleFidUpd@ are not enough, because -- periodic actions could have invalidated them. factionD <- getsState sfactionD mapM_ updatePerFid (EM.keys factionD) -- Saving on the browser causes a huge lag, hence autosave disabled. #ifndef USE_JSFILE unless breakLoop2 $ -- if by chance requested and periodic saves coincide -- Periodic save needs to be at the end, so that restore can start -- at the beginning. when (clipN `mod` rwriteSaveClips rules == 0) $ writeSaveAll False #endif -- | Check if the given actor is dominated and update his calm. manageCalmAndDomination :: MonadServerAtomic m => ActorId -> Actor -> m () manageCalmAndDomination aid b = do fact <- getsState $ (EM.! bfid b) . sfactionD hiImpression <- highestImpression aid dominated <- if bcalm b == 0 && fleaderMode (gplayer fact) /= LeaderNull -- animals/robots/human drones never Calm-dominated then maybe (return False) (dominateFidSfx aid) hiImpression else return False unless dominated $ do newCalmDelta <- getsState $ regenCalmDelta aid b unless (newCalmDelta == 0) $ -- Update delta for the current player turn. udpateCalm aid newCalmDelta -- | Trigger periodic items for all actors on the given level. applyPeriodicLevel :: MonadServerAtomic m => m () applyPeriodicLevel = do arenas <- getsServer sarenas let arenasSet = ES.fromDistinctAscList arenas applyPeriodicItem _ _ _ (_, (_, [])) = return () -- periodic items always have at least one timer applyPeriodicItem aid cstore getStore (iid, _) = do -- Check if the item is still in the bag (previous items act!). bag <- getsState $ getStore . getActorBody aid case iid `EM.lookup` bag of Nothing -> return () -- item dropped Just kit -> do itemFull@ItemFull{itemKind} <- getsState $ itemToFull iid when (IK.Periodic `elem` IK.ifeature itemKind) $ -- In periodic activation, consider *only* recharging effects. -- Activate even if effects null, to possibly destroy item. effectAndDestroy False aid aid iid (CActor aid cstore) True (IK.filterRecharging $ IK.ieffects itemKind) (itemFull, kit) applyPeriodicActor (aid, b) = when (not (bproj b) && blid b `ES.member` arenasSet) $ do mapM_ (applyPeriodicItem aid COrgan borgan) $ EM.assocs $ borgan b mapM_ (applyPeriodicItem aid CEqp beqp) $ EM.assocs $ beqp b -- While we are at it, also update their calm. manageCalmAndDomination aid b allActors <- getsState sactorD mapM_ applyPeriodicActor $ EM.assocs allActors handleTrajectories :: MonadServerAtomic m => LevelId -> FactionId -> m () handleTrajectories lid fid = do localTime <- getsState $ getLocalTime lid levelTime <- getsServer $ (EM.! lid) . (EM.! fid) . sactorTime getActorB <- getsState $ flip getActorBody let l = map (fst . snd) $ sortBy (Ord.comparing fst) $ filter (\(_, (_, b)) -> isJust (btrajectory b) || bhp b <= 0) $ map (\(a, atime) -> (atime, (a, getActorB a))) $ filter (\(_, atime) -> atime <= localTime) $ EM.assocs levelTime -- The actor body obtained above may be outdated before @hTrajectories@ -- call (due to other actors following their trajectories), -- so it's only used to decide which actors are processed in this -- @handleTrajectories@ call and not passed to @hTrajectories@. -- If the actor no longer fulfills the criteria above, @hTrajectories@ -- ignores it. If it starts fulfilling them, the recursive call -- to @handleTrajectories@ will detect that and process him later on. -- If the actor is no longer on the level or no longer belongs -- to the faction, it is nevertheless processed without a problem. -- We are guaranteed the actor still exists. mapM_ hTrajectories l unless (null l) $ handleTrajectories lid fid -- for speeds > tile/clip hTrajectories :: MonadServerAtomic m => ActorId -> m () {-# INLINE hTrajectories #-} hTrajectories aid = do b1 <- getsState $ getActorBody aid if | actorDying b1 -> dieSer aid b1 | isJust (btrajectory b1) -> do -- don't advance time if no trajectory setTrajectory aid b1 -- @setTrajectory@ might have affected @actorDying@, so we check again -- ASAP to make sure the body of the projectile (or pushed actor) -- doesn't block movement of other actors, but vanishes promptly. -- Bodies of actors that die not flying remain on the battlefied until -- their natural next turn, to give them a chance of rescue. -- Note that domination of pushed actors is not checked -- nor is their calm updated. They are helpless wrt movement, -- but also invulnerable in this respect. b2 <- getsState $ getActorBody aid if actorDying b2 then dieSer aid b2 else advanceTime aid 100 False | otherwise -> return () -- no longer fulfills citeria, ignore him -- if @actorDying@ due to @bhp b <= 0@: -- If @b@ is a projectile, it means hits an actor or is hit by actor. -- Then the carried item is destroyed and that's all. -- If @b@ is not projectile, it dies, his items drop to the ground -- and possibly a new leader is elected. -- -- if @actorDying@ due to @btrajectory@ null: -- A projectile drops to the ground due to obstacles or range. -- The carried item is not destroyed, unless it's fragile, -- but drops to the ground. -- | Manage trajectory of a projectile. -- -- 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 :: MonadServerAtomic m => ActorId -> Actor -> m () {-# INLINE setTrajectory #-} setTrajectory aid b = do COps{coTileSpeedup} <- getsState scops lvl <- getLevel $ blid b case btrajectory b of Just (d : lv, speed) -> do let tpos = bpos b `shift` d -- target position if Tile.isWalkable coTileSpeedup $ lvl `at` tpos then do -- 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. case posToAidsLvl tpos lvl of [target] | not (bproj b) -> reqDisplace aid target _ -> reqMove aid d b2 <- getsState $ getActorBody aid unless ((fst <$> btrajectory b2) == Just []) $ -- set in reqMelee execUpdAtomic $ UpdTrajectory aid (btrajectory b2) (Just (lv, speed)) else do -- @Nothing@ trajectory of a projectile signals an obstacle hit. -- The second call of @actorDying@ above will catch the dead projectile. execUpdAtomic $ UpdTrajectory aid (btrajectory b) Nothing if bproj b then -- Lose HP due to hitting an obstacle. when (bhp b > oneM) $ execUpdAtomic $ UpdRefillHP aid minusM else do execSfxAtomic $ SfxCollideTile aid tpos mfail <- reqAlterFail aid tpos case mfail of Nothing -> return () -- too late to announce anything Just{} -> -- Altering failed, probably just a wall, so lose HP -- due to being pushed into an obstacle. Never kill in this way. when (bhp b > oneM) $ do execUpdAtomic $ UpdRefillHP aid minusM let effect = IK.RefillHP (-2) -- -2 is a lie to ensure display execSfxAtomic $ SfxEffect (bfid b) aid effect (-1) Just ([], _) -> -- Non-projectile actor stops flying (a projectile with empty trajectory -- would be intercepted earlier on as dead). assert (not $ bproj b) $ execUpdAtomic $ UpdTrajectory aid (btrajectory b) Nothing _ -> error $ "Nothing trajectory" `showFailure` (aid, b) handleActors :: (MonadServerAtomic m, MonadServerComm m) => LevelId -> FactionId -> m Bool handleActors lid fid = do localTime <- getsState $ getLocalTime lid levelTime <- getsServer $ (EM.! lid) . (EM.! fid) . sactorTime getActorB <- getsState $ flip getActorBody let l = map (fst . snd) $ sortBy (Ord.comparing fst) $ filter (\(_, (_, b)) -> isNothing (btrajectory b) && bhp b > 0) $ map (\(a, atime) -> (atime, (a, getActorB a))) $ filter (\(_, atime) -> atime <= localTime) $ EM.assocs levelTime -- The actor body obtained above may be outdated before @hActors@ -- call gets to it (due to other actors on the list acting), -- so it's only used to decide which actors are processed in this call. -- If the actor is no longer on the level or no longer belongs -- to the faction, it is nevertheless processed without a problem -- (the client may act wrt slightly outdated Perception and that's all). -- We are guaranteed the actor still exists. mleader <- getsState $ gleader . (EM.! fid) . sfactionD -- Leader acts first, so that UI leader can save&exit before state changes. hActors $ case mleader of Just aid | aid `elem` l -> aid : delete aid l _ -> l hActors :: forall m. (MonadServerAtomic m, MonadServerComm m) => [ActorId] -> m Bool hActors [] = return False hActors as@(aid : rest) = do b1 <- getsState $ getActorBody aid let side = bfid b1 !_A = assert (not $ bproj b1) () fact <- getsState $ (EM.! side) . sfactionD breakLoop <- getsServer sbreakLoop let mleader = gleader fact aidIsLeader = mleader == Just aid mainUIactor = fhasUI (gplayer fact) && (aidIsLeader || fleaderMode (gplayer fact) == LeaderNull) -- Checking squit, to avoid doubly setting faction status to Camping -- in case AI-controlled UI client asks to exit game at exactly -- the same moment as natural game over was detected. mainUIunderAI = mainUIactor && isAIFact fact && not breakLoop doQueryAI = not mainUIactor || isAIFact fact when mainUIunderAI $ do cmdS <- sendQueryUI side aid case fst cmdS of ReqUINop -> return () ReqUIAutomate -> execUpdAtomic $ UpdAutoFaction side False ReqUIGameDropAndExit -> reqGameDropAndExit aid ReqUIGameSaveAndExit -> reqGameSaveAndExit aid _ -> error $ "" `showFailure` cmdS breakASAP <- getsServer sbreakASAP -- If breaking out of the game lopp, pretend there was a non-wait move. if breakASAP then return True else do let mswitchLeader :: Maybe ActorId -> m ActorId {-# NOINLINE mswitchLeader #-} mswitchLeader (Just aidNew) = switchLeader side aidNew >> return aidNew mswitchLeader Nothing = return aid (aidNew, mtimed) <- if doQueryAI then do (cmd, maid) <- sendQueryAI side aid aidNew <- mswitchLeader maid mtimed <- handleRequestAI cmd return (aidNew, mtimed) else do (cmd, maid) <- sendQueryUI side aid aidNew <- mswitchLeader maid mtimed <- handleRequestUI side aidNew cmd return (aidNew, mtimed) case mtimed of Just timed -> do nonWaitMove <- handleRequestTimed side aidNew timed -- Even if the actor got a free turn of time via a scroll, -- he will not act again this clip, only next clip. -- Clip is small, so not a big deal and it's faster and avoids -- complete game time freezes, e.g., due to an exploit. if nonWaitMove then return True else hActors rest Nothing -> do breakASAP2 <- getsServer sbreakASAP -- If breaking out of the game lopp, pretend there was a non-wait move. if breakASAP2 then return True else hActors as restartGame :: MonadServerAtomic m => m () -> m () -> Maybe (GroupName ModeKind) -> m () restartGame updConn loop mgameMode = do soptionsNxt <- getsServer soptionsNxt srandom <- getsServer srandom s <- gameReset soptionsNxt mgameMode (Just srandom) let optionsBarRngs = soptionsNxt {sdungeonRng = Nothing, smainRng = Nothing} modifyServer $ \ser -> ser { soptionsNxt = optionsBarRngs , soptions = optionsBarRngs } execUpdAtomic $ UpdRestartServer s updConn initPer reinitGame writeSaveAll False loop LambdaHack-0.8.3.0/Game/LambdaHack/Server/StartM.hs0000644000000000000000000003674713315545734017704 0ustar0000000000000000-- | Operations for starting and restarting the game. module Game.LambdaHack.Server.StartM ( initPer, reinitGame, gameReset, applyDebug #ifdef EXPOSE_INTERNAL -- * Internal operations , mapFromFuns, resetFactions, populateDungeon, findEntryPoss #endif ) where import Prelude () import Game.LambdaHack.Common.Prelude import qualified Control.Monad.Trans.State.Strict as St import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES import qualified Data.IntMap.Strict as IM import Data.Key (mapWithKeyM_) import qualified Data.Map.Strict as M import Data.Ord import qualified Data.Text as T import Data.Tuple (swap) import qualified NLP.Miniutter.English as MU import qualified System.Random as R import Game.LambdaHack.Atomic 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.Flavour import Game.LambdaHack.Common.Item import Game.LambdaHack.Common.Kind import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.MonadStateRead import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.Random 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.ModeKind import Game.LambdaHack.Server.CommonM import qualified Game.LambdaHack.Server.DungeonGen as DungeonGen import Game.LambdaHack.Server.Fov import Game.LambdaHack.Server.ItemM import Game.LambdaHack.Server.ItemRev import Game.LambdaHack.Server.MonadServer import Game.LambdaHack.Server.ServerOptions import Game.LambdaHack.Server.State initPer :: MonadServer m => m () initPer = do ( sfovLitLid, sfovClearLid, sfovLucidLid ,sperValidFid, sperCacheFid, sperFid ) <- getsState perFidInDungeon modifyServer $ \ser -> ser { sfovLitLid, sfovClearLid, sfovLucidLid , sperValidFid, sperCacheFid, sperFid } reinitGame :: MonadServerAtomic m => m () reinitGame = do COps{coitem} <- getsState scops pers <- getsServer sperFid ServerOptions{scurChalSer, sknowMap, sclientOptions} <- getsServer soptions -- 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 discoS <- getsState sdiscoKind -- Thanks to the following, for any item with not hidden identity, -- the client has its kind from the start. let discoKindFiltered = let f kindId = isNothing $ IK.getHideAs $ okind coitem kindId in EM.filter f discoS defL | sknowMap = s | otherwise = localFromGlobal s defLocal = updateDiscoKind (const discoKindFiltered) defL factionD <- getsState sfactionD modifyServer $ \ser -> ser {sclientStates = EM.map (const defLocal) factionD} let updRestart fid = UpdRestart fid (pers EM.! fid) defLocal scurChalSer sclientOptions mapWithKeyM_ (\fid _ -> execUpdAtomic $ updRestart fid) factionD dungeon <- getsState sdungeon let sactorTime = EM.map (const (EM.map (const EM.empty) dungeon)) factionD modifyServer $ \ser -> ser {sactorTime} populateDungeon mapM_ (\fid -> mapM_ (updatePer fid) (EM.keys dungeon)) (EM.keys factionD) execSfxAtomic SfxSortSlots 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 resetFactions :: FactionDict -> ContentId ModeKind -> Int -> Dice.AbsDepth -> Roster -> Rnd FactionDict resetFactions factionDold gameModeIdOld curDiffSerOld totalDepth players = do let rawCreate (gplayer@Player{..}, initialActors) = do let castInitialActors (ln, d, actorGroup) = do n <- castDice (Dice.AbsDepth $ abs ln) totalDepth d return (ln, n, actorGroup) ginitial <- mapM castInitialActors initialActors let cmap = mapFromFuns [colorToTeamName, colorToPlainName, colorToFancyName] colorName = T.toLower $ head $ T.words fname prefix = case fleaderMode of LeaderNull -> "Loose" LeaderAI _ -> "Autonomous" LeaderUI _ -> "Controlled" gnameNew = prefix <+> if fhasGender then makePhrase [MU.Ws $ MU.Text fname] else fname gcolor = M.findWithDefault Color.BrWhite colorName cmap gvictimsDnew = case find (\fact -> gname fact == gnameNew) $ EM.elems factionDold of Nothing -> EM.empty Just fact -> let sing = IM.singleton curDiffSerOld (gvictims fact) f = IM.unionWith (EM.unionWith (+)) in EM.insertWith f gameModeIdOld sing $ gvictimsD fact let gname = gnameNew gdipl = EM.empty -- fixed below gquit = Nothing _gleader = Nothing gvictims = EM.empty gvictimsD = gvictimsDnew gsha = EM.empty return $! Faction{..} lUI <- mapM rawCreate $ filter (fhasUI . fst) $ rosterList players let !_A = assert (length lUI <= 1 `blame` "currently, at most one faction may have a UI" `swith` lUI) () lnoUI <- mapM rawCreate $ filter (not . fhasUI . fst) $ 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) _ -> error $ "unknown faction" `showFailure` ((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 => ServerOptions -> Maybe (GroupName ModeKind) -> Maybe R.StdGen -> m State gameReset serverOptions mGameMode mrandom = do -- Dungeon seed generation has to come first, to ensure item boosting -- is determined by the dungeon RNG. cops@COps{comode} <- getsState scops dungeonSeed <- getSetGen $ sdungeonRng serverOptions `mplus` mrandom srandom <- getSetGen $ smainRng serverOptions `mplus` mrandom let srngs = RNGs (Just dungeonSeed) (Just srandom) when (sdumpInitRngs serverOptions) $ dumpRngs srngs scoreTable <- restoreScore cops factionDold <- getsState sfactionD gameModeIdOld <- getsState sgameModeId curChalSer <- getsServer $ scurChalSer . soptions #ifdef USE_BROWSER let startingModeGroup = "starting JS" #else let startingModeGroup = "starting" #endif gameMode = fromMaybe startingModeGroup $ mGameMode `mplus` sgameMode serverOptions rnd :: Rnd (FactionDict, FlavourMap, DiscoveryKind, DiscoveryKindRev, DungeonGen.FreshDungeon, ContentId ModeKind) rnd = do modeKindId <- fromMaybe (error $ "Unknown game mode:" `showFailure` gameMode) <$> opick comode gameMode (const True) let mode = okind comode modeKindId automatePS ps = ps {rosterList = map (first $ automatePlayer True) $ rosterList ps} players = if sautomateAll serverOptions then automatePS $ mroster mode else mroster mode sflavour <- dungeonFlavourMap cops (discoKind, sdiscoKindRev) <- serverDiscos cops freshDng <- DungeonGen.dungeonGen cops $ mcaves mode factionD <- resetFactions factionDold gameModeIdOld (cdiff curChalSer) (DungeonGen.freshTotalDepth freshDng) players return ( factionD, sflavour, discoKind , sdiscoKindRev, freshDng, modeKindId ) let ( factionD, sflavour, discoKind ,sdiscoKindRev, DungeonGen.FreshDungeon{..}, modeKindId ) = St.evalState rnd dungeonSeed defState = defStateGlobal freshDungeon freshTotalDepth factionD cops scoreTable modeKindId discoKind defSer = emptyStateServer { srandom , srngs } putServer defSer modifyServer $ \ser -> ser {sdiscoKindRev, sflavour} return $! defState -- Spawn initial actors. Clients should notice this, to set their leaders. populateDungeon :: MonadServerAtomic m => m () populateDungeon = do cops@COps{coTileSpeedup} <- getsState scops dungeon <- getsState sdungeon factionD <- getsState sfactionD curChalSer <- getsServer $ scurChalSer . soptions let ginitialWolf fact1 = if cwolf curChalSer && fhasUI (gplayer fact1) then case ginitial fact1 of [] -> [] (ln, _, grp) : _ -> [(ln, 1, grp)] else ginitial fact1 (minD, maxD) = case (EM.minViewWithKey dungeon, EM.maxViewWithKey dungeon) of (Just ((s, _), _), Just ((e, _), _)) -> (s, e) _ -> error $ "empty dungeon" `showFailure` 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 (not . null . ginitialWolf . snd) $ EM.assocs factionD g (ln, _, _) = max minD . min maxD . toEnum $ ln getEntryLevels (_, fact) = map g $ ginitialWolf fact arenas = ES.toList $ ES.fromList $ concatMap getEntryLevels needInitialCrew hasActorsOnArena lid (_, fact) = any ((== lid) . g) $ ginitialWolf fact initialActorPositions lid = do lvl <- getLevel lid let arenaFactions = filter (hasActorsOnArena lid) needInitialCrew indexff (fid, _) = findIndex ((== fid) . fst) arenaFactions representsAlliance ff2@(fid2, fact2) = not $ any (\ff3@(fid3, _) -> indexff ff3 < indexff ff2 && isFriend fid2 fact2 fid3) arenaFactions arenaAlliances = filter representsAlliance arenaFactions entryPoss <- rndToAction $ findEntryPoss cops lid lvl (length arenaAlliances) let usedPoss = zip3 arenaAlliances entryPoss [0..] return $! (lid, usedPoss) initialActors (lid, usedPoss) = do let arenaFactions = filter (hasActorsOnArena lid) needInitialCrew placeAlliance ((fid3, _), ppos, timeOffset) = mapM_ (\(fid4, fact4) -> when (isFriend fid4 fact4 fid3) $ placeActors lid ((fid4, fact4), ppos, timeOffset)) arenaFactions mapM_ placeAlliance usedPoss placeActors lid ((fid3, fact3), ppos, timeOffset) = do localTime <- getsState $ getLocalTime lid let clipInTurn = timeTurn `timeFit` timeClip nmult = 1 + timeOffset `mod` clipInTurn ntime = timeShift localTime (timeDeltaScale (Delta timeClip) nmult) validTile t = not $ Tile.isNoActor coTileSpeedup t initActors = ginitialWolf fact3 initGroups = concat [ replicate n actorGroup | ln3@(_, n, actorGroup) <- initActors , g ln3 == lid ] psFree <- getsState $ nearbyFreePoints validTile ppos lid let ps = zip initGroups psFree forM_ ps $ \ (actorGroup, p) -> do maid <- addActorFromGroup actorGroup fid3 p lid ntime case maid of Nothing -> error $ "can't spawn initial actors" `showFailure` (lid, (fid3, fact3)) Just aid -> do mleader <- getsState $ gleader . (EM.! fid3) . sfactionD when (isNothing mleader) $ supplantLeader fid3 aid return True lposs <- mapM initialActorPositions arenas let alliancePositions = EM.fromList $ map (second $ map $ \(_, l, _) -> l) lposs placeItemsInDungeon alliancePositions embedItemsInDungeon mapM_ initialActors lposs -- | Find starting postions for all factions. Try to make them distant -- from each other. Place as many of the factions, as possible, -- over stairs, starting from the end of the list, including placing the last -- factions over escapes (we assume they are guardians of the escapes). -- This implies the inital factions (if any) start far from escapes. findEntryPoss :: COps -> LevelId -> Level -> Int -> Rnd [Point] findEntryPoss COps{coTileSpeedup} lid Level{ltile, lxsize, lysize, lstair, lescape} k = do let factionDist = max lxsize lysize - 10 dist poss cmin l _ = all (\pos -> chessDist l pos > cmin) poss tryFind _ 0 = return [] tryFind ps n = do let ds = [ dist ps $ factionDist `div` 2 , dist ps $ factionDist `div` 3 , dist ps $ factionDist `div` 4 , dist ps $ factionDist `div` 6 ] np <- findPosTry2 1000 ltile -- try really hard, for skirmish fairness (\_ t -> Tile.isWalkable coTileSpeedup t && not (Tile.isNoActor coTileSpeedup t)) ds (\_p t -> Tile.isOftenActor coTileSpeedup t) ds nps <- tryFind (np : ps) (n - 1) return $! np : nps -- Only consider deeper stairs to avoid leaderless spawners that lurk near -- their starting stairs ambushing explorers that enter the level, -- unless the staircase has both sets of stairs. deeperStairs = (if fromEnum lid > 0 then fst else snd) lstair middlePos = Point (lxsize `div` 2) (lysize `div` 2) let !_A = assert (k > 0 && factionDist > 0) () onStairs = reverse $ take k $ lescape ++ deeperStairs nk = k - length onStairs -- Starting in the middle is too easy. found <- tryFind (middlePos : onStairs) nk return $! found ++ onStairs -- | Apply options that don't need a new game. applyDebug :: MonadServer m => m () applyDebug = do ServerOptions{..} <- getsServer soptionsNxt modifyServer $ \ser -> ser {soptions = (soptions ser) { sniff , sallClear , sdbgMsgSer , snewGameSer , sdumpInitRngs , sclientOptions }} LambdaHack-0.8.3.0/Game/LambdaHack/Server/ItemM.hs0000644000000000000000000001725713315545734017500 0ustar0000000000000000-- | Server operations for items. module Game.LambdaHack.Server.ItemM ( registerItem, embedItem, rollItem, rollAndRegisterItem , placeItemsInDungeon, embedItemsInDungeon, mapActorCStore_ #ifdef EXPOSE_INTERNAL -- * Internal operations , onlyRegisterItem, createLevelItem #endif ) where import Prelude () import Game.LambdaHack.Common.Prelude 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.Ord import Game.LambdaHack.Atomic import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState import Game.LambdaHack.Common.ContentData import Game.LambdaHack.Common.Item import Game.LambdaHack.Common.Kind import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.MonadStateRead import Game.LambdaHack.Common.Point import 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.Content.CaveKind (citemFreq, citemNum) import Game.LambdaHack.Content.ItemKind (ItemKind) import qualified Game.LambdaHack.Content.ItemKind as IK import Game.LambdaHack.Content.TileKind (TileKind) import Game.LambdaHack.Server.ItemRev import Game.LambdaHack.Server.MonadServer import Game.LambdaHack.Server.ServerOptions import Game.LambdaHack.Server.State onlyRegisterItem :: MonadServerAtomic m => ItemKnown -> m ItemId onlyRegisterItem itemKnown@(_, aspectRecord, _) = do itemRev <- getsServer sitemRev case HM.lookup itemKnown itemRev of Just iid -> return iid Nothing -> do icounter <- getsServer sicounter executedOnServer <- execUpdAtomicSer $ UpdDiscoverServer icounter aspectRecord let !_A = assert executedOnServer () modifyServer $ \ser -> ser { sitemRev = HM.insert itemKnown icounter (sitemRev ser) , sicounter = succ icounter } return $! icounter registerItem :: MonadServerAtomic m => ItemFullKit -> ItemKnown -> Container -> Bool -> m ItemId registerItem (ItemFull{itemBase, itemKindId, itemKind}, kit) itemKnown@(_, aspectRecord, _) container verbose = do iid <- onlyRegisterItem itemKnown let cmd = if verbose then UpdCreateItem else UpdSpotItem False execUpdAtomic $ cmd iid itemBase kit container let worth = itemPrice (fst kit) itemKind unless (worth == 0) $ execUpdAtomic $ UpdAlterGold worth knowItems <- getsServer $ sknowItems . soptions when knowItems $ case container of CTrunk{} -> return () _ -> execUpdAtomic $ UpdDiscover container iid itemKindId aspectRecord return iid createLevelItem :: MonadServerAtomic m => Point -> LevelId -> m () createLevelItem pos lid = do COps{cocave} <- getsState scops Level{lkind} <- getLevel lid let container = CFloor lid pos litemFreq = citemFreq $ okind cocave lkind void $ rollAndRegisterItem lid litemFreq container True Nothing embedItem :: MonadServerAtomic m => LevelId -> Point -> ContentId TileKind -> m () embedItem lid pos tk = do COps{cotile} <- getsState scops let embeds = Tile.embeddedItems cotile tk container = CEmbed lid pos f grp = rollAndRegisterItem lid [(grp, 1)] container False Nothing mapM_ f embeds rollItem :: MonadServerAtomic m => Int -> LevelId -> Freqs ItemKind -> m (Maybe (ItemKnown, ItemFullKit, 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 m3 <- rndToAction $ newItem cops flavour discoRev uniqueSet itemFreq lvlSpawned lid ldepth totalDepth case m3 of Just (_, (ItemFull{itemKindId, itemKind}, _), _) -> when (IK.Unique `elem` IK.ifeature itemKind) $ modifyServer $ \ser -> ser {suniqueSet = ES.insert itemKindId (suniqueSet ser)} _ -> return () return m3 rollAndRegisterItem :: MonadServerAtomic m => LevelId -> Freqs ItemKind -> Container -> Bool -> Maybe Int -> m (Maybe (ItemId, (ItemFullKit, GroupName ItemKind))) rollAndRegisterItem lid itemFreq container verbose mk = do -- Power depth of new items unaffected by number of spawned actors. m3 <- rollItem 0 lid itemFreq case m3 of Nothing -> return Nothing Just (itemKnown, (itemFull, kit), itemGroup) -> do let kit2 = (fromMaybe (fst kit) mk, snd kit) iid <- registerItem (itemFull, kit2) itemKnown container verbose return $ Just (iid, ((itemFull, kit2), itemGroup)) placeItemsInDungeon :: forall m. MonadServerAtomic m => EM.EnumMap LevelId [Point] -> m () placeItemsInDungeon alliancePositions = do COps{cocave, coTileSpeedup} <- getsState scops totalDepth <- getsState stotalDepth let initialItems (lid, Level{lkind, ldepth, lxsize, lysize, ltile}) = do litemNum <- rndToAction $ castDice ldepth totalDepth (citemNum $ okind cocave lkind) let placeItems :: Int -> m () placeItems n | n == litemNum = return () placeItems !n = do Level{lfloor} <- getLevel lid -- We ensure that there are no big regions without items at all. let distAndOften !p !t = let f !k _ b = chessDist p k > 6 && b in Tile.isOftenItem coTileSpeedup t && EM.foldrWithKey f True lfloor alPos = EM.findWithDefault [] lid alliancePositions -- Don't generate items around initial actors or in tiles. distAllianceAndNotFloor !p _ = let f !k b = chessDist p k > 4 && b in p `EM.notMember` lfloor && foldr f True alPos pos <- rndToAction $ findPosTry2 200 ltile (\_ !t -> Tile.isWalkable coTileSpeedup t && not (Tile.isNoItem coTileSpeedup t)) -- If there are very many items, some regions may be very rich, -- but let's try to spread at least the initial items evenly. ([distAndOften | n * 100 < lxsize * lysize] ++ [\_ !t -> Tile.isOftenItem coTileSpeedup t]) distAllianceAndNotFloor [distAllianceAndNotFloor] createLevelItem pos lid placeItems (n + 1) placeItems 0 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 :: MonadServerAtomic m => m () embedItemsInDungeon = do let embedItems (lid, Level{ltile}) = PointArray.imapMA_ (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 -- | 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 $ getBodyStoreBag b cstore mapM_ (uncurry f) $ EM.assocs bag LambdaHack-0.8.3.0/Game/LambdaHack/Server/DebugM.hs0000644000000000000000000000754513315545734017627 0ustar0000000000000000-- | Debug output for requests and responses. module Game.LambdaHack.Server.DebugM ( debugResponse , debugRequestAI, debugRequestUI #ifdef EXPOSE_INTERNAL -- * Internal operations , debugShow, debugPretty, debugPlain, DebugAid(..), debugAid #endif ) where import Prelude () import Game.LambdaHack.Common.Prelude import qualified Data.EnumMap.Strict as EM import Data.Int (Int64) import qualified Data.Text as T import qualified Text.Show.Pretty as Show.Pretty import Game.LambdaHack.Atomic import Game.LambdaHack.Client (Response (..)) import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.MonadStateRead import Game.LambdaHack.Common.Time import Game.LambdaHack.Server.MonadServer import Game.LambdaHack.Server.State -- We debug these on the server, not on the clients, because we want -- a single log, knowing the order in which the server received requests -- and sent responseQs. Clients interleave and block non-deterministically -- so their logs would be harder to interpret. debugShow :: Show a => a -> Text debugShow = T.pack . Show.Pretty.ppShow debugResponse :: MonadServer m => FactionId -> Response -> m () debugResponse fid resp = case resp of RespUpdAtomic _ cmd@UpdPerception{} -> debugPlain fid "RespUpdAtomic" cmd RespUpdAtomic _ cmd@UpdResume{} -> debugPlain fid "RespUpdAtomic" cmd RespUpdAtomic _ cmd@UpdRestart{} -> debugPlain fid "RespUpdAtomic" cmd RespUpdAtomic _ cmd@UpdSpotTile{} -> debugPlain fid "RespUpdAtomic" cmd RespUpdAtomic _ cmd@(UpdCreateActor aid _ _) -> do d <- debugAid aid "UpdCreateActor" serverPrint d debugPretty fid "RespUpdAtomic" cmd RespUpdAtomic _ cmd@(UpdSpotActor aid _ _) -> do d <- debugAid aid "UpdSpotActor" serverPrint d debugPretty fid "RespUpdAtomic" cmd RespUpdAtomic _ cmd -> debugPretty fid "RespUpdAtomic" cmd RespUpdAtomicNoState cmd@UpdPerception{} -> debugPlain fid "RespUpdAtomicNoState" cmd RespUpdAtomicNoState cmd@UpdResume{} -> debugPlain fid "RespUpdAtomicNoState" cmd RespUpdAtomicNoState cmd@UpdSpotTile{} -> debugPlain fid "RespUpdAtomicNoState" cmd RespUpdAtomicNoState cmd -> debugPretty fid "RespUpdAtomicNoState" cmd RespQueryAI aid -> do d <- debugAid aid "RespQueryAI" serverPrint d RespSfxAtomic sfx -> do -- not so crucial so no details ps <- posSfxAtomic sfx serverPrint $ debugShow (fid, "RespSfxAtomic" :: Text, ps) RespQueryUI -> serverPrint "RespQueryUI" debugPretty :: MonadServer m => FactionId -> Text -> UpdAtomic -> m () debugPretty fid t cmd = do ps <- posUpdAtomic cmd serverPrint $ debugShow (fid, t, ps, cmd) debugPlain :: MonadServer m => FactionId -> Text -> UpdAtomic -> m () debugPlain fid t cmd = do ps <- posUpdAtomic cmd serverPrint $ T.pack $ show (fid, t, ps, cmd) -- too large for pretty printing debugRequestAI :: MonadServer m => ActorId -> m () debugRequestAI aid = do d <- debugAid aid "AI request" serverPrint d debugRequestUI :: MonadServer m => ActorId -> m () debugRequestUI aid = do d <- debugAid aid "UI request" serverPrint d data DebugAid = DebugAid { label :: Text , aid :: ActorId , faction :: FactionId , lid :: LevelId , bHP :: Int64 , btime :: Time , time :: Time } deriving Show debugAid :: MonadServer m => ActorId -> Text -> m Text debugAid aid label = do b <- getsState $ getActorBody aid time <- getsState $ getLocalTime (blid b) btime <- getsServer $ (EM.! aid) . (EM.! blid b) . (EM.! bfid b) . sactorTime return $! debugShow DebugAid { label , aid , faction = bfid b , lid = blid b , bHP = bhp b , btime , time } LambdaHack-0.8.3.0/Game/LambdaHack/Server/Fov.hs0000644000000000000000000003312113315545734017203 0ustar0000000000000000-- | Field Of View scanning. -- -- See -- for discussion. module Game.LambdaHack.Server.Fov ( -- * Perception cache FovValid(..), PerValidFid , PerReachable(..), CacheBeforeLucid(..), PerActor , PerceptionCache(..), PerCacheLid, PerCacheFid -- * Data used in FOV computation and cached to speed it up , FovShine(..), FovLucid(..), FovLucidLid , FovClear(..), FovClearLid, FovLit (..), FovLitLid -- * Operations , perceptionFromPTotal, perActorFromLevel, boundSightByCalm , totalFromPerActor, lucidFromLevel, perFidInDungeon #ifdef EXPOSE_INTERNAL -- * Internal operations , cacheBeforeLucidFromActor, shineFromLevel, floorLightSources, lucidFromItems , litFromLevel, litInDungeon, clearFromLevel, clearInDungeon, lucidInDungeon , perLidFromFaction, perceptionCacheFromLevel , Matrix, fullscan #endif ) where import Prelude () import Game.LambdaHack.Common.Prelude import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES import Data.Int (Int64) import GHC.Exts (inline) import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.ItemAspect as IA import Game.LambdaHack.Common.Kind import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.Perception import Game.LambdaHack.Common.Point import qualified Game.LambdaHack.Common.PointArray as PointArray import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile import Game.LambdaHack.Common.Vector import Game.LambdaHack.Server.FovDigital -- * Perception cache types data FovValid a = FovValid a | FovInvalid deriving (Show, Eq) -- | Main perception validity map, for all factions. type PerValidFid = EM.EnumMap FactionId (EM.EnumMap LevelId Bool) -- | Visually reachable positions (light passes through them to the actor). -- They need to be intersected with lucid positions to obtain visible positions. newtype PerReachable = PerReachable {preachable :: ES.EnumSet Point} deriving (Show, Eq) data CacheBeforeLucid = CacheBeforeLucid { creachable :: PerReachable , cnocto :: PerVisible , csmell :: PerSmelled } deriving (Show, Eq) type PerActor = EM.EnumMap ActorId (FovValid CacheBeforeLucid) -- We might cache even more effectively in terms of Enum{Set,Map} unions -- if we recorded for each field how many actors see it (and how many -- lights lit it). But this is complex and unions of EnumSets are cheaper -- than the EnumMaps that would be required. data PerceptionCache = PerceptionCache { ptotal :: FovValid CacheBeforeLucid , perActor :: PerActor } deriving (Show, Eq) -- | Server cache of perceptions of a single faction, -- indexed by level identifier. type PerCacheLid = EM.EnumMap LevelId PerceptionCache -- | Server cache of perceptions, indexed by faction identifier. type PerCacheFid = EM.EnumMap FactionId PerCacheLid -- * Data used in FOV computation -- | Map from level positions that currently hold item or actor(s) with shine -- to the maximum of radiuses of the shining lights. -- -- Note that floor and (many projectile) actors light on a single tile -- should be additive for @FovShine@ to be incrementally updated. -- -- @FovShine@ should not even be kept in @StateServer@, because it's cheap -- to compute, compared to @FovLucid@ and invalidated almost as often -- (not invalidated only by @UpdAlterTile@). newtype FovShine = FovShine {fovShine :: EM.EnumMap Point Int} deriving (Show, Eq) -- | Level positions with either ambient light or shining items or actors. newtype FovLucid = FovLucid {fovLucid :: ES.EnumSet Point} deriving (Show, Eq) type FovLucidLid = EM.EnumMap LevelId (FovValid FovLucid) -- | Level positions that pass through light and vision. newtype FovClear = FovClear {fovClear :: PointArray.Array Bool} deriving (Show, Eq) type FovClearLid = EM.EnumMap LevelId FovClear -- | Level positions with tiles that have ambient light. newtype FovLit = FovLit {fovLit :: ES.EnumSet Point} deriving (Show, Eq) type FovLitLid = EM.EnumMap LevelId FovLit -- * Update of invalidated Fov data -- | Compute positions visible (reachable and seen) by the party. -- A position is lucid, if it's lit by an ambient light or by a weak, portable -- light source, e.g,, carried by an actor. A reachable and lucid position -- is visible. Additionally, positions directly adjacent to an actor are -- assumed to be visible to him (through sound, touch, noctovision, whatever). perceptionFromPTotal :: FovLucid -> CacheBeforeLucid -> Perception perceptionFromPTotal FovLucid{fovLucid} ptotal = let nocto = pvisible $ cnocto ptotal reach = preachable $ creachable ptotal psight = PerVisible $ nocto `ES.union` (reach `ES.intersection` fovLucid) psmell = csmell ptotal in Perception{..} perActorFromLevel :: PerActor -> (ActorId -> Actor) -> ActorAspect -> FovClear -> PerActor perActorFromLevel perActorOld getActorB actorAspect fovClear = -- Dying actors included, to let them see their own demise. let f _ fv@FovValid{} = fv f aid FovInvalid = let ar = actorAspect EM.! aid b = getActorB aid in FovValid $ cacheBeforeLucidFromActor fovClear b ar in EM.mapWithKey f perActorOld boundSightByCalm :: Int -> Int64 -> Int boundSightByCalm sight calm = min (fromEnum $ calm `div` (5 * oneM)) sight -- | Compute positions reachable by the actor. Reachable are all fields -- on a visually unblocked path from the actor position. -- Also compute positions seen by noctovision and perceived by smell. cacheBeforeLucidFromActor :: FovClear -> Actor -> IA.AspectRecord -> CacheBeforeLucid cacheBeforeLucidFromActor clearPs body IA.AspectRecord{..} = let radius = boundSightByCalm aSight (bcalm body) creachable = PerReachable $ fullscan clearPs radius (bpos body) cnocto = PerVisible $ fullscan clearPs aNocto (bpos body) smellRadius = if aSmell >= 2 then 2 else 0 csmell = PerSmelled $ fullscan clearPs smellRadius (bpos body) in CacheBeforeLucid{..} totalFromPerActor :: PerActor -> CacheBeforeLucid totalFromPerActor perActor = let as = map (\case FovValid x -> x FovInvalid -> error $ "" `showFailure` perActor) $ EM.elems perActor in CacheBeforeLucid { creachable = PerReachable $ ES.unions $ map (preachable . creachable) as , cnocto = PerVisible $ ES.unions $ map (pvisible . cnocto) as , csmell = PerSmelled $ ES.unions $ map (psmelled . csmell) as } -- | Update lights on the level. This is needed every (even enemy) -- actor move to show thrown torches. -- We need to update lights even if cmd doesn't change any perception, -- so that for next cmd that does, but doesn't change lights, -- and operates on the same level, the lights are up to date. -- We could make lights lazy to ensure no computation is wasted, -- but it's rare that cmd changed them, but not the perception -- (e.g., earthquake in an uninhabited corner of the active arena, -- but the we'd probably want some feedback, at least sound). lucidFromLevel :: FovClearLid -> FovLitLid -> State -> LevelId -> Level -> FovLucid lucidFromLevel fovClearLid fovLitLid s lid lvl = let shine = shineFromLevel s lid lvl lucids = lucidFromItems (fovClearLid EM.! lid) $ EM.assocs $ fovShine shine litTiles = fovLitLid EM.! lid in FovLucid $ ES.unions $ fovLit litTiles : map fovLucid lucids shineFromLevel :: State -> LevelId -> Level -> FovShine shineFromLevel s lid lvl = let actorLights = [ (bpos b, radius) | (aid, b) <- inline actorAssocs (const True) lid s , let radius = IA.aShine $ sactorAspect s EM.! aid , radius > 0 ] floorLights = floorLightSources (sdiscoAspect s) lvl allLights = floorLights ++ actorLights -- If there is light both on the floor and carried by actor -- (or several projectile actors), its radius is the maximum. in FovShine $ EM.fromListWith max allLights floorLightSources :: DiscoveryAspect -> Level -> [(Point, Int)] floorLightSources discoAspect lvl = -- Not enough oxygen to have more than one light lit on a given tile. -- Items obscuring or dousing off fire are not cumulative as well. let processIid (accLight, accDouse) (iid, _) = let IA.AspectRecord{aShine} = discoAspect EM.! iid in case compare aShine 0 of EQ -> (accLight, accDouse) GT -> (max aShine accLight, accDouse) LT -> (accLight, min aShine accDouse) processBag bag acc = foldl' processIid acc $ EM.assocs bag in [ (p, radius) | (p, bag) <- EM.assocs $ lfloor lvl -- lembed are hidden , let (maxLight, maxDouse) = processBag bag (0, 0) radius = maxLight + maxDouse , radius > 0 ] -- | Compute all dynamically lit positions on a level, whether lit by actors -- or shining floor items. Note that an actor can be blind, -- in which case he doesn't see his own light (but others, -- from his or other factions, possibly do). lucidFromItems :: FovClear -> [(Point, Int)] -> [FovLucid] lucidFromItems clearPs allItems = let lucidPos (p, shine) = FovLucid $ fullscan clearPs shine p in map lucidPos allItems -- * Computation of initial perception and caches -- | Calculate the perception and its caches for the whole dungeon. perFidInDungeon :: State -> ( FovLitLid, FovClearLid, FovLucidLid , PerValidFid, PerCacheFid, PerFid) perFidInDungeon s = let fovLitLid = litInDungeon s fovClearLid = clearInDungeon s fovLucidLid = lucidInDungeon fovClearLid fovLitLid s perValidLid = EM.map (const True) (sdungeon s) perValidFid = EM.map (const perValidLid) (sfactionD s) f fid _ = perLidFromFaction fovLucidLid fovClearLid fid s em = EM.mapWithKey f $ sfactionD s in ( fovLitLid, fovClearLid, fovLucidLid , perValidFid, EM.map snd em, EM.map fst em) litFromLevel :: COps -> Level -> FovLit litFromLevel COps{coTileSpeedup} Level{ltile} = let litSet p t set = if Tile.isLit coTileSpeedup t then p : set else set in FovLit $ ES.fromDistinctAscList $ PointArray.ifoldrA' litSet [] ltile litInDungeon :: State -> FovLitLid litInDungeon s = EM.map (litFromLevel (scops s)) $ sdungeon s clearFromLevel :: COps -> Level -> FovClear clearFromLevel COps{coTileSpeedup} Level{ltile} = FovClear $ PointArray.mapA (Tile.isClear coTileSpeedup) ltile clearInDungeon :: State -> FovClearLid clearInDungeon s = EM.map (clearFromLevel (scops s)) $ sdungeon s lucidInDungeon :: FovClearLid -> FovLitLid -> State-> FovLucidLid lucidInDungeon fovClearLid fovLitLid s = EM.mapWithKey (\lid lvl -> FovValid $ lucidFromLevel fovClearLid fovLitLid s lid lvl) $ sdungeon s -- | Calculate perception of a faction. perLidFromFaction :: FovLucidLid -> FovClearLid -> FactionId -> State -> (PerLid, PerCacheLid) perLidFromFaction fovLucidLid fovClearLid fid s = let em = EM.mapWithKey (\lid _ -> perceptionCacheFromLevel fovClearLid fid lid s) (sdungeon s) fovLucid lid = case EM.lookup lid fovLucidLid of Just (FovValid fl) -> fl _ -> error $ "" `showFailure` (lid, fovLucidLid) getValid (FovValid pc) = pc getValid FovInvalid = error $ "" `showFailure` fid in ( EM.mapWithKey (\lid pc -> perceptionFromPTotal (fovLucid lid) (getValid (ptotal pc))) em , em ) perceptionCacheFromLevel :: FovClearLid -> FactionId -> LevelId -> State -> PerceptionCache perceptionCacheFromLevel fovClearLid fid lid s = let fovClear = fovClearLid EM.! lid lvlBodies = inline actorAssocs (== fid) lid s f (aid, b) = let ar@IA.AspectRecord{..} = sactorAspect s EM.! aid in if aSight <= 0 && aNocto <= 0 && aSmell <= 0 -- dumb missiles then Nothing else Just (aid, FovValid $ cacheBeforeLucidFromActor fovClear b ar) lvlCaches = mapMaybe f lvlBodies perActor = EM.fromDistinctAscList lvlCaches total = totalFromPerActor perActor in PerceptionCache{ptotal = FovValid total, perActor} -- * The actual Fov algorithm type Matrix = (Int, Int, Int, Int) -- | Perform a full scan for a given position. Returns the positions -- that are currently in the field of view. The Field of View -- algorithm to use is passed in the second argument. -- The actor's own position is considred reachable by him. fullscan :: FovClear -- ^ the array with clear points -> Int -- ^ scanning radius -> Point -- ^ position of the spectator -> ES.EnumSet Point fullscan FovClear{fovClear} radius spectatorPos = if | radius <= 0 -> ES.empty | radius == 1 -> ES.singleton spectatorPos | radius == 2 -> inline squareUnsafeSet spectatorPos | otherwise -> mapTr (1, 0, 0, -1) -- quadrant I $ mapTr (0, 1, 1, 0) -- II (counter-clockwise) $ mapTr (-1, 0, 0, 1) -- III $ mapTr (0, -1, -1, 0) -- IV $ ES.singleton spectatorPos where mapTr :: Matrix -> ES.EnumSet Point -> ES.EnumSet Point mapTr m@(!_, !_, !_, !_) es = scan es (radius - 1) fovClear (trV m) -- This function is cheap, so no problem it's called twice -- for some points: once for @isClear@, once in @outside@. trV :: Matrix -> Bump -> Point {-# INLINE trV #-} trV (x1, y1, x2, y2) B{..} = shift spectatorPos $ Vector (x1 * bx + y1 * by) (x2 * bx + y2 * by) LambdaHack-0.8.3.0/Game/LambdaHack/Server/CommonM.hs0000644000000000000000000006054313315545734020026 0ustar0000000000000000{-# LANGUAGE TupleSections #-} -- | Server operations common to many modules. module Game.LambdaHack.Server.CommonM ( revealItems, moveStores, generalMoveItem , deduceQuits, deduceKilled, electLeader, supplantLeader , updatePer, recomputeCachePer, projectFail , addActorFromGroup, registerActor, discoverIfMinorEffects , pickWeaponServer, currentSkillsServer #ifdef EXPOSE_INTERNAL -- * Internal operations , containerMoveItem, quitF, keepArenaFact, anyActorsAlive, projectBla , addProjectile, addActorIid, getCacheLucid, getCacheTotal #endif ) where import Prelude () import Game.LambdaHack.Common.Prelude import qualified Data.EnumMap.Strict as EM 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.ItemAspect as IA import Game.LambdaHack.Common.Kind import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.MonadStateRead import Game.LambdaHack.Common.Perception import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.Random import Game.LambdaHack.Common.ReqFailure import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile import Game.LambdaHack.Common.Time import Game.LambdaHack.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.ItemM import Game.LambdaHack.Server.ItemRev import Game.LambdaHack.Server.MonadServer import Game.LambdaHack.Server.ServerOptions import Game.LambdaHack.Server.State revealItems :: MonadServerAtomic m => Maybe FactionId -> m () revealItems mfid = do COps{coitem} <- getsState scops let discover aid store iid _ = do itemKindId <- getsState $ getIidKindIdServer iid let itemKind = okind coitem itemKindId c = CActor aid store unless (IK.isHumanTrinket itemKind) $ do -- a hack discoAspect <- getsState sdiscoAspect execUpdAtomic $ UpdDiscover c iid itemKindId $ discoAspect EM.! iid 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 as <- getsState $ EM.keys . sactorD mapM_ f as moveStores :: MonadServerAtomic m => Bool -> ActorId -> CStore -> CStore -> m () moveStores verbose aid fromStore toStore = do b <- getsState $ getActorBody aid let g iid (k, _) = do move <- generalMoveItem verbose iid k (CActor aid fromStore) (CActor aid toStore) mapM_ execUpdAtomic move mapActorCStore_ fromStore g b -- | Generate the atomic updates that jointly perform a given item move. generalMoveItem :: MonadStateRead m => Bool -> ItemId -> Int -> Container -> Container -> m [UpdAtomic] generalMoveItem verbose iid k c1 c2 = case (c1, c2) of (CActor aid1 cstore1, CActor aid2 cstore2) | aid1 == aid2 && cstore1 /= CSha && cstore2 /= CSha -> return [UpdMoveItem iid k aid1 cstore1 cstore2] _ -> containerMoveItem verbose iid k c1 c2 containerMoveItem :: MonadStateRead m => Bool -> ItemId -> Int -> Container -> Container -> m [UpdAtomic] containerMoveItem verbose iid k c1 c2 = do bag <- getsState $ getContainerBag c1 case iid `EM.lookup` bag of Nothing -> error $ "" `showFailure` (iid, k, c1, c2) Just (_, it) -> do item <- getsState $ getItemBody iid return [ UpdLoseItem verbose iid item (k, take k it) c1 , UpdSpotItem verbose iid item (k, take k it) c2 ] quitF :: MonadServerAtomic m => Status -> FactionId -> m () quitF status fid = do fact <- getsState $ (EM.! fid) . sfactionD let oldSt = gquit fact -- Note that it's the _old_ status that we check here. case stOutcome <$> oldSt of Just Killed -> return () -- Do not overwrite in case Just Defeated -> return () -- many things happen in 1 turn. Just Conquer -> return () Just Escape -> return () _ -> do -- This runs regardless of the _new_ status. when (fhasUI $ gplayer fact) $ do keepAutomated <- getsServer $ skeepAutomated . soptions -- Try to remove AI control of the UI faction, to show endgame info. when (isAIFact fact && fleaderMode (gplayer fact) /= LeaderNull && not keepAutomated) $ execUpdAtomic $ UpdAutoFaction fid False revealItems (Just fid) -- Likely, by this time UI faction is no longer AI-controlled, -- so the score will get registered. registerScore status fid execUpdAtomic $ UpdQuitFaction fid oldSt $ Just status modifyServer $ \ser -> ser {sbreakLoop = True} -- check game over -- Send any UpdQuitFaction actions that can be deduced from factions' -- current state. deduceQuits :: MonadServerAtomic m => FactionId -> Status -> m () deduceQuits fid0 status@Status{stOutcome} | stOutcome `elem` [Defeated, Camping, Restart, Conquer] = error $ "no quitting to deduce" `showFailure` (fid0, status) deduceQuits fid0 status = do fact0 <- getsState $ (EM.! fid0) . sfactionD let factHasUI = fhasUI . gplayer quitFaction (stOutcome, (fid, _)) = quitF status{stOutcome} fid mapQuitF outfids = do let (withUI, withoutUI) = partition (factHasUI . snd . snd) ((stOutcome status, (fid0, fact0)) : outfids) mapM_ quitFaction (withoutUI ++ withUI) inGameOutcome (fid, fact) = do let mout | fid == fid0 = Just $ stOutcome status | otherwise = stOutcome <$> gquit fact case mout of Just Killed -> False Just Defeated -> False Just Restart -> False -- effectively, commits suicide _ -> True factionD <- getsState sfactionD let assocsInGame = filter inGameOutcome $ EM.assocs factionD assocsKeepArena = filter (keepArenaFact . snd) assocsInGame assocsUI = filter (factHasUI . snd) assocsInGame nonHorrorAIG = filter (not . isHorrorFact . snd) assocsInGame worldPeace = all (\(fid1, _) -> all (\(fid2, fact2) -> not $ isFoe fid2 fact2 fid1) nonHorrorAIG) nonHorrorAIG othersInGame = filter ((/= fid0) . fst) assocsInGame if | null assocsUI -> -- Only non-UI players left in the game and they all win. mapQuitF $ zip (repeat Conquer) othersInGame | null assocsKeepArena -> -- Only leaderless and spawners remain (the latter may sometimes -- have no leader, just as the former), so they win, -- or we could get stuck in a state with no active arena -- and so no spawns. mapQuitF $ zip (repeat Conquer) othersInGame | worldPeace -> -- Nobody is at war any more, so all win (e.g., horrors, but never mind). mapQuitF $ zip (repeat Conquer) othersInGame | stOutcome status == Escape -> do -- Otherwise, in a game with many warring teams alive, -- only complete Victory matters, until enough of them die. let (victors, losers) = partition (\(fi, _) -> isFriend fid0 fact0 fi) othersInGame mapQuitF $ zip (repeat Escape) victors ++ zip (repeat Defeated) losers | otherwise -> quitF status fid0 -- | 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 argument has HP <= 0 or is going to be -- dominated right now. Even if the actor is to be dominated, -- @bfid@ of the actor body is still the old faction. deduceKilled :: MonadServerAtomic m => ActorId -> m () deduceKilled aid = do cops <- getsState scops body <- getsState $ getActorBody aid let firstDeathEnds = rfirstDeathEnds $ getStdRuleset cops fact <- getsState $ (EM.! bfid body) . sfactionD when (fneverEmpty $ gplayer fact) $ do actorsAlive <- anyActorsAlive (bfid body) aid when (not actorsAlive || firstDeathEnds) $ deduceQuits (bfid body) $ Status Killed (fromEnum $ blid body) Nothing anyActorsAlive :: MonadServer m => FactionId -> ActorId -> m Bool anyActorsAlive fid aid = do as <- getsState $ fidActorNotProjAssocs fid -- We test HP here, in case more than one actor goes to 0 HP in the same turn. return $! any (\(aid2, b2) -> aid2 /= aid && bhp b2 > 0) as electLeader :: MonadServerAtomic m => FactionId -> LevelId -> ActorId -> m () electLeader fid lid aidDead = do mleader <- getsState $ gleader . (EM.! fid) . sfactionD when (mleader == Just aidDead) $ do actorD <- getsState sactorD let ours (_, b) = bfid b == fid && not (bproj b) party = filter ours $ EM.assocs actorD -- Prefer actors on level and with positive HP. (positive, negative) = partition (\(_, b) -> bhp b > 0) party onLevel <- getsState $ fidActorRegularIds fid lid let mleaderNew = case filter (/= aidDead) $ onLevel ++ map fst (positive ++ negative) of [] -> Nothing aid : _ -> Just aid execUpdAtomic $ UpdLeadFaction fid mleader mleaderNew supplantLeader :: MonadServerAtomic m => FactionId -> ActorId -> m () supplantLeader fid aid = do fact <- getsState $ (EM.! fid) . sfactionD unless (fleaderMode (gplayer fact) == LeaderNull) $ do -- First update and send Perception so that the new leader -- may report his environment. b <- getsState $ getActorBody aid let !_A = assert (not $ bproj b) () valid <- getsServer $ (EM.! blid b) . (EM.! fid) . sperValidFid unless valid $ updatePer fid (blid b) execUpdAtomic $ UpdLeadFaction fid (gleader fact) (Just aid) updatePer :: MonadServerAtomic m => FactionId -> LevelId -> m () {-# INLINE updatePer #-} updatePer fid lid = do modifyServer $ \ser -> ser {sperValidFid = EM.adjust (EM.insert lid True) fid $ sperValidFid ser} sperFidOld <- getsServer sperFid let perOld = sperFidOld EM.! fid EM.! lid -- Performed in the State after action, e.g., with a new actor. perNew <- recomputeCachePer fid lid let inPer = diffPer perNew perOld outPer = diffPer perOld perNew unless (nullPer outPer && nullPer inPer) $ execSendPer fid lid outPer inPer perNew recomputeCachePer :: MonadServer m => FactionId -> LevelId -> m Perception recomputeCachePer fid lid = do total <- getCacheTotal fid lid fovLucid <- getCacheLucid lid let perNew = perceptionFromPTotal fovLucid total fper = EM.adjust (EM.insert lid perNew) fid modifyServer $ \ser -> ser {sperFid = fper $ sperFid ser} return perNew -- The missile item is removed from the store only if the projection -- went into effect (no failure occured). projectFail :: MonadServerAtomic m => ActorId -- ^ actor projecting the item (is on current lvl) -> Point -- ^ target position of the projectile -> Int -- ^ digital line parameter -> Bool -- ^ whether to start at the source position -> 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 center iid cstore blast = do COps{coTileSpeedup} <- 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 [] -> error $ "projecting from the edge of level" `showFailure` (spos, tpxy) Just (pos : restUnlimited) -> do bag <- getsState $ getBodyStoreBag sb cstore case EM.lookup iid bag of Nothing -> return $ Just ProjectOutOfReach Just _kit -> do itemFull@ItemFull{itemKind} <- getsState $ itemToFull iid actorSk <- currentSkillsServer source ar <- getsState $ getActorAspect source let skill = EM.findWithDefault 0 Ability.AbProject actorSk forced = blast || bproj sb calmE = calmEnough sb ar legal = permittedProject forced skill calmE itemFull case legal of Left reqFail -> return $ Just reqFail Right _ -> do let lobable = IK.Lobable `elem` IK.ifeature itemKind rest = if lobable then take (chessDist spos tpxy - 1) restUnlimited else restUnlimited t = lvl `at` pos if not $ Tile.isWalkable coTileSpeedup t then return $ Just ProjectBlockTerrain else do lab <- getsState $ posToAssocs pos lid if not $ all (bproj . snd) lab then if blast && bproj sb then do -- Hit the blocking actor. projectBla source spos (pos:rest) iid cstore blast return Nothing else return $ Just ProjectBlockActor else do -- Make the explosion less regular and weaker at edges. if blast && bproj sb && center then -- Start in the center, not around. projectBla source spos (pos:rest) iid cstore blast else projectBla source pos rest iid cstore blast return Nothing projectBla :: MonadServerAtomic 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 blast = do sb <- getsState $ getActorBody source let lid = blid sb localTime <- getsState $ getLocalTime lid unless blast $ execSfxAtomic $ SfxProject source iid cstore bag <- getsState $ getBodyStoreBag sb cstore ItemFull{itemBase, itemKind} <- getsState $ itemToFull iid case iid `EM.lookup` bag of Nothing -> error $ "" `showFailure` (source, pos, rest, iid, cstore) Just kit@(_, it) -> do let delay = if IK.iweight itemKind == 0 then timeTurn else timeClip btime = absoluteTimeAdd delay localTime addProjectile pos rest iid kit lid (bfid sb) btime let c = CActor source cstore execUpdAtomic $ UpdLoseItem False iid itemBase (1, take 1 it) c addActorFromGroup :: MonadServerAtomic m => GroupName ItemKind -> FactionId -> Point -> LevelId -> Time -> m (Maybe ActorId) addActorFromGroup actorGroup bfid pos lid time = do -- We bootstrap the actor by first creating the trunk of the actor's body -- that contains the constant properties. let trunkFreq = [(actorGroup, 1)] m3 <- rollItem 0 lid trunkFreq case m3 of Nothing -> return Nothing Just (itemKnown, itemFullKit, _) -> Just <$> registerActor False itemKnown itemFullKit bfid pos lid time registerActor :: MonadServerAtomic m => Bool -> ItemKnown -> ItemFullKit -> FactionId -> Point -> LevelId -> Time -> m ActorId registerActor summoned (kindIx, ar, _) (itemFullRaw, kit) bfid pos lid time = do let container = CTrunk bfid lid pos jfid = Just bfid itemKnown = (kindIx, ar, jfid) itemFull = itemFullRaw {itemBase = (itemBase itemFullRaw) {jfid}} trunkId <- registerItem (itemFull, kit) itemKnown container False addNonProjectile summoned trunkId (itemFull, kit) bfid pos lid time addProjectile :: MonadServerAtomic m => Point -> [Point] -> ItemId -> ItemQuant -> LevelId -> FactionId -> Time -> m () addProjectile bpos rest iid (_, it) blid bfid btime = do itemFull <- getsState $ itemToFull iid let (trajectory, (speed, _)) = IK.itemTrajectory (itemKind itemFull) (bpos : rest) -- Trunk is added to equipment, not to organs, because it's the -- projected item, so it's carried, not grown. tweakBody b = b { bhp = oneM , btrajectory = Just (trajectory, speed) , beqp = EM.singleton iid (1, take 1 it) } void $ addActorIid iid itemFull True bfid bpos blid tweakBody btime addNonProjectile :: MonadServerAtomic m => Bool -> ItemId -> ItemFullKit -> FactionId -> Point -> LevelId -> Time -> m ActorId addNonProjectile summoned trunkId (itemFull, kit) fid pos lid time = do let tweakBody b = b { borgan = EM.singleton trunkId kit , bcalm = if summoned then bcalm b * 2 `div` 3 - xM 3 -- will summon in 3 turns, if calm regenerates else bcalm b } addActorIid trunkId itemFull False fid pos lid tweakBody time addActorIid :: MonadServerAtomic m => ItemId -> ItemFull -> Bool -> FactionId -> Point -> LevelId -> (Actor -> Actor) -> Time -> m ActorId addActorIid trunkId ItemFull{itemBase, itemKind, itemDisco} bproj bfid pos lid tweakBody time = do -- Initial HP and Calm is based only on trunk and ignores organs. let hp = xM (max 2 $ IA.aMaxHP $ itemAspect itemDisco) `div` 2 -- Hard to auto-id items that refill Calm, but reduced sight at game -- start is more confusing and frustrating: calm = xM (max 0 $ IA.aMaxCalm $ itemAspect itemDisco) -- Create actor. factionD <- getsState sfactionD curChalSer <- getsServer $ scurChalSer . soptions 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 $ cdiff curChalSer hasUIorEscapes Faction{gplayer} = fhasUI gplayer || nU == 0 && fcanEscape gplayer boostFact = not bproj && if diffBonusCoeff > 0 then any (hasUIorEscapes . snd) (filter (\(fi, fa) -> isFriend fi fa bfid) (EM.assocs factionD)) else any (hasUIorEscapes . snd) (filter (\(fi, fa) -> isFoe fi fa bfid) (EM.assocs factionD)) diffHP | boostFact = if cdiff curChalSer `elem` [1, difficultyBound] then xM 999 - hp -- as much as UI can stand else hp * 2 ^ abs diffBonusCoeff | otherwise = hp bonusHP = fromEnum $ (diffHP - hp) `divUp` oneM healthOrgans = [(Just bonusHP, ("bonus HP", COrgan)) | bonusHP /= 0] b = actorTemplate trunkId diffHP calm pos lid bfid bproj -- Insert the trunk as the actor's organ. withTrunk = b {bweapon = if IK.isMelee itemKind then 1 else 0} aid <- getsServer sacounter modifyServer $ \ser -> ser {sacounter = succ aid} modifyServer $ \ser -> ser {sactorTime = updateActorTime bfid lid aid time $ sactorTime ser} 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 itemKind)) $ \(mk, (ikText, cstore)) -> do let container = CActor aid cstore itemFreq = [(ikText, 1)] mIidEtc <- rollAndRegisterItem lid itemFreq container False mk case mIidEtc of Nothing -> error $ "" `showFailure` (lid, itemFreq, container, mk) Just (iid, ((itemFull2, _), _)) -> -- The items are create in inventory, so won't be picked up, -- so we have to discover them now, if eligible. discoverIfMinorEffects container iid (itemKindId itemFull2) return aid discoverIfMinorEffects :: MonadServerAtomic m => Container -> ItemId -> ContentId ItemKind -> m () discoverIfMinorEffects c iid itemKindId = do COps{coitem} <- getsState scops let itemKind = okind coitem itemKindId if IK.onlyMinorEffects itemKind then do discoAspect <- getsState sdiscoAspect execUpdAtomic $ UpdDiscover c iid itemKindId $ discoAspect EM.! iid else return () -- discover by use when item's effects get activated later on pickWeaponServer :: MonadServer m => ActorId -> m (Maybe (ItemId, CStore)) pickWeaponServer source = do eqpAssocs <- getsState $ kitAssocs source [CEqp] bodyAssocs <- getsState $ kitAssocs source [COrgan] actorSk <- currentSkillsServer source sb <- getsState $ getActorBody source let kitAssRaw = eqpAssocs ++ bodyAssocs forced = bproj sb kitAss | forced = kitAssRaw -- for projectiles, anything is weapon | otherwise = filter (IK.isMelee . itemKind . fst . snd) kitAssRaw -- Server ignores item effects or it would leak item discovery info. -- In particular, it even uses weapons that would heal opponent, -- and not only in case of projectiles. strongest <- pickWeaponM Nothing kitAss actorSk source case strongest 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) -- @MonadStateRead@ would be enough, but the logic is sound only on server. currentSkillsServer :: MonadServer m => ActorId -> m Ability.Skills currentSkillsServer aid = do body <- getsState $ getActorBody aid fact <- getsState $ (EM.! bfid body) . sfactionD let mleader = gleader fact getsState $ actorSkills mleader aid getCacheLucid :: MonadServer m => LevelId -> m FovLucid getCacheLucid lid = do fovClearLid <- getsServer sfovClearLid fovLitLid <- getsServer sfovLitLid fovLucidLid <- getsServer sfovLucidLid let getNewLucid = getsState $ \s -> lucidFromLevel fovClearLid fovLitLid s lid (sdungeon s EM.! lid) case EM.lookup lid fovLucidLid of Just (FovValid fovLucid) -> return fovLucid _ -> do newLucid <- getNewLucid modifyServer $ \ser -> ser {sfovLucidLid = EM.insert lid (FovValid newLucid) $ sfovLucidLid ser} return newLucid getCacheTotal :: MonadServer m => FactionId -> LevelId -> m CacheBeforeLucid getCacheTotal fid lid = do sperCacheFidOld <- getsServer sperCacheFid let perCacheOld = sperCacheFidOld EM.! fid EM.! lid case ptotal perCacheOld of FovValid total -> return total FovInvalid -> do actorAspect <- getsState sactorAspect fovClearLid <- getsServer sfovClearLid getActorB <- getsState $ flip getActorBody let perActorNew = perActorFromLevel (perActor perCacheOld) getActorB actorAspect (fovClearLid EM.! lid) -- We don't check if any actor changed, because almost surely one is. -- Exception: when an actor is destroyed, but then union differs, too. total = totalFromPerActor perActorNew perCache = PerceptionCache { ptotal = FovValid total , perActor = perActorNew } fperCache = EM.adjust (EM.insert lid perCache) fid modifyServer $ \ser -> ser {sperCacheFid = fperCache $ sperCacheFid ser} return total LambdaHack-0.8.3.0/Game/LambdaHack/Server/PeriodicM.hs0000644000000000000000000003461313315545734020333 0ustar0000000000000000-- | Server operations performed periodically in the game loop -- and related operations. module Game.LambdaHack.Server.PeriodicM ( spawnMonster, addAnyActor , advanceTime, overheadActorTime, swapTime, udpateCalm, leadLevelSwitch #ifdef EXPOSE_INTERNAL -- * Internal operations , rollSpawnPos #endif ) where import Prelude () import Game.LambdaHack.Common.Prelude import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES import Data.Int (Int64) import Data.Ord import Game.LambdaHack.Atomic import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState import Game.LambdaHack.Common.ContentData import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.Frequency import Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.ItemAspect as IA import Game.LambdaHack.Common.Kind import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.MonadStateRead import Game.LambdaHack.Common.Perception import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.Random import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile import Game.LambdaHack.Common.Time import qualified Game.LambdaHack.Content.CaveKind as CK import Game.LambdaHack.Content.ItemKind (ItemKind) import qualified Game.LambdaHack.Content.ItemKind as IK import Game.LambdaHack.Content.ModeKind import Game.LambdaHack.Server.CommonM import Game.LambdaHack.Server.ItemM import Game.LambdaHack.Server.MonadServer import Game.LambdaHack.Server.State -- | Spawn, possibly, a monster according to the level's actor groups. -- We assume heroes are never spawned. spawnMonster :: MonadServerAtomic m => m () spawnMonster = do COps{cocave} <- getsState scops arenas <- getsServer sarenas -- 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 Level{lkind, ldepth} <- getLevel arena let ck = okind cocave lkind unless (CK.cactorCoeff ck == 0 || null (CK.cactorFreq ck)) $ do totalDepth <- getsState stotalDepth lvlSpawned <- getsServer $ fromMaybe 0 . EM.lookup arena . snumSpawned rc <- rndToAction $ monsterGenChance ldepth totalDepth lvlSpawned (CK.cactorCoeff ck) when rc $ do modifyServer $ \ser -> ser {snumSpawned = EM.insert arena (lvlSpawned + 1) $ snumSpawned ser} localTime <- getsState $ getLocalTime arena maid <- addAnyActor False (CK.cactorFreq ck) arena localTime Nothing case maid of Nothing -> return () -- suspect content Just aid -> do b <- getsState $ getActorBody aid mleader <- getsState $ gleader . (EM.! bfid b) . sfactionD when (isNothing mleader) $ supplantLeader (bfid b) aid addAnyActor :: MonadServerAtomic m => Bool -> Freqs ItemKind -> LevelId -> Time -> Maybe Point -> m (Maybe ActorId) addAnyActor summoned actorFreq lid time mpos = do -- We bootstrap the actor by first creating the trunk of the actor's body -- that contains the constant properties. cops <- getsState scops lvl <- getLevel lid factionD <- getsState sfactionD lvlSpawned <- getsServer $ fromMaybe 0 . EM.lookup lid . snumSpawned m3 <- rollItem lvlSpawned lid actorFreq case m3 of Nothing -> return Nothing Just (itemKnownRaw, (itemFullRaw, kit), _) -> do let freqNames = map fst $ IK.ifreq $ itemKind itemFullRaw f fact = fgroups (gplayer fact) factGroups = concatMap f $ EM.elems factionD fidNames = case freqNames `intersect` factGroups of [] -> [nameOfHorrorFact] -- fall back l -> l fidName <- rndToAction $ oneOf fidNames let g (_, fact) = fidName `elem` fgroups (gplayer fact) nameFids = map fst $ filter g $ EM.assocs factionD !_A = assert (not (null nameFids) `blame` (factionD, fidName)) () fid <- rndToAction $ oneOf nameFids pers <- getsServer sperFid let allPers = ES.unions $ map (totalVisible . (EM.! lid)) $ EM.elems $ EM.delete fid pers -- expensive :( -- Checking skill would be more accurate, but skills can be -- inside organs, equipment, tmp organs, created organs, etc. mobile = "mobile" `elem` freqNames pos <- case mpos of Just pos -> return pos Nothing -> do rollPos <- getsState $ rollSpawnPos cops allPers mobile lid lvl fid rndToAction rollPos Just <$> registerActor summoned itemKnownRaw (itemFullRaw, kit) fid pos lid time rollSpawnPos :: COps -> ES.EnumSet Point -> Bool -> LevelId -> Level -> FactionId -> State -> Rnd Point rollSpawnPos COps{coTileSpeedup} visible mobile lid lvl@Level{ltile, lxsize, lysize, lstair} fid s = do let -- Monsters try to harass enemies ASAP, instead of catching up from afar. inhabitants = foeRegularList fid lid s nearInh df p = all (\b -> df $ chessDist (bpos b) p) inhabitants -- Monsters often appear from deeper levels or at least we try -- to suggest that. deeperStairs = (if fromEnum lid > 0 then fst else snd) lstair nearStairs df p = any (\pstair -> df $ chessDist pstair p) deeperStairs -- Near deep stairs, risk of close enemy spawn is higher. -- Also, spawns are common midway between actors and stairs. distantSo df p _ = nearInh df p && nearStairs df p middlePos = Point (lxsize `div` 2) (lysize `div` 2) distantMiddle d p _ = chessDist p middlePos < d condList | mobile = [ distantSo (<= 15) , distantSo (<= 20) , distantSo (<= 25) ] | otherwise = [ 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. findPosTry2 (if mobile then 500 else 100) ltile ( \p t -> Tile.isWalkable coTileSpeedup t && not (Tile.isNoActor coTileSpeedup t) && null (posToAidsLvl p lvl)) condList (\p t -> distantSo (> 4) p t -- otherwise actors in dark rooms swarmed && not (p `ES.member` visible)) -- visibility and plausibility [ \p t -> distantSo (> 3) p t && not (p `ES.member` visible) , \p t -> distantSo (> 2) p t -- otherwise actors hit on entering level && not (p `ES.member` visible) , \p _ -> not (p `ES.member` visible) ] -- | Advance the move time for the given actor. advanceTime :: MonadServerAtomic m => ActorId -> Int -> Bool -> m () advanceTime aid percent breakStasis = do b <- getsState $ getActorBody aid ar <- getsState $ getActorAspect aid let t = timeDeltaPercent (ticksPerMeter $ momentarySpeed b ar) percent -- @t@ may be negative; that's OK. modifyServer $ \ser -> ser {sactorTime = ageActor (bfid b) (blid b) aid t $ sactorTime ser} when breakStasis $ modifyServer $ \ser -> ser {sactorStasis = ES.delete aid (sactorStasis ser)} -- actor moved, so he broke the time stasis, he can be -- paralyzed as well as propelled again -- | Add communication overhead time delta to all non-projectile, non-dying -- faction's actors, except the leader. Effectively, this limits moves -- of a faction on a level to 10, regardless of the number of actors -- and their speeds. To avoid animals suddenly acting extremely sluggish -- whenever monster's leader visits a distant arena that has a crowd -- of animals, overhead applies only to actors on the same level. -- Since the number of active levels is limited, this bounds the total moves -- per turn of each faction as well. -- -- Leader is immune from overhead and so he is faster than other faction -- members and of equal speed to leaders of other factions (of equal -- base speed) regardless how numerous the faction is. -- Thanks to this, there is no problem with leader of a numerous faction -- having very long UI turns, introducing UI lag. overheadActorTime :: MonadServerAtomic m => FactionId -> LevelId -> m () overheadActorTime fid lid = do actorTimeFid <- getsServer $ (EM.! fid) . sactorTime let actorTimeLid = actorTimeFid EM.! lid getActorB <- getsState $ flip getActorBody mleader <- getsState $ gleader . (EM.! fid) . sfactionD let f !aid !time = let body = getActorB aid in if isNothing (btrajectory body) && bhp body > 0 -- speed up all-move-at-once carcass removal && Just aid /= mleader -- leader fast, for UI to be fast then timeShift time (Delta timeClip) else time actorTimeLid2 = EM.mapWithKey f actorTimeLid actorTimeFid2 = EM.insert lid actorTimeLid2 actorTimeFid modifyServer $ \ser -> ser {sactorTime = EM.insert fid actorTimeFid2 $ sactorTime ser} -- | Swap the relative move times of two actors (e.g., when switching -- a UI leader). swapTime :: MonadServerAtomic m => ActorId -> ActorId -> m () swapTime source target = do sb <- getsState $ getActorBody source tb <- getsState $ getActorBody target slvl <- getsState $ getLocalTime (blid sb) tlvl <- getsState $ getLocalTime (blid tb) btime_sb <- getsServer $ (EM.! source) . (EM.! blid sb) . (EM.! bfid sb) . sactorTime btime_tb <- getsServer $ (EM.! target) . (EM.! blid tb) . (EM.! bfid tb) . sactorTime let lvlDelta = slvl `timeDeltaToFrom` tlvl bDelta = btime_sb `timeDeltaToFrom` btime_tb sdelta = timeDeltaSubtract lvlDelta bDelta tdelta = timeDeltaReverse sdelta -- Equivalent, for the assert: let !_A = let sbodyDelta = btime_sb `timeDeltaToFrom` slvl tbodyDelta = btime_tb `timeDeltaToFrom` tlvl sgoal = slvl `timeShift` tbodyDelta tgoal = tlvl `timeShift` sbodyDelta sdelta' = sgoal `timeDeltaToFrom` btime_sb tdelta' = tgoal `timeDeltaToFrom` btime_tb in assert (sdelta == sdelta' && tdelta == tdelta' `blame` ( slvl, tlvl, btime_sb, btime_tb , sdelta, sdelta', tdelta, tdelta' )) () when (sdelta /= Delta timeZero) $ modifyServer $ \ser -> ser {sactorTime = ageActor (bfid sb) (blid sb) source sdelta $ sactorTime ser} when (tdelta /= Delta timeZero) $ modifyServer $ \ser -> ser {sactorTime = ageActor (bfid tb) (blid tb) target tdelta $ sactorTime ser} udpateCalm :: MonadServerAtomic m => ActorId -> Int64 -> m () udpateCalm target deltaCalm = do tb <- getsState $ getActorBody target ar <- getsState $ getActorAspect target let calmMax64 = xM $ IA.aMaxCalm ar execUpdAtomic $ UpdRefillCalm target deltaCalm when (bcalm tb < calmMax64 && bcalm tb + deltaCalm >= calmMax64) $ return () -- We don't dominate the actor here, because if so, players would -- disengage after one of their actors is dominated and wait for him -- to regenerate Calm. This is unnatural and boring. Better fight -- and hope he gets his Calm again to 0 and then defects back. leadLevelSwitch :: MonadServerAtomic m => m () leadLevelSwitch = do COps{cocave} <- 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 (fid, fact) = case gleader fact of Nothing -> return () Just leader -> do body <- getsState $ getActorBody leader let !_A = assert (fid == bfid body) () s <- getsServer $ (EM.! fid) . sclientStates let leaderStuck = waitedLastTurn body oursRaw = [ (lid, (allSeen, as)) | (lid, lvl) <- EM.assocs $ sdungeon s , lid /= blid body || not leaderStuck , let as = -- Drama levels ignored, hence @Regular@. fidActorRegularIds fid lid s , not (null as) , let allSeen = lexpl lvl <= lseen lvl || CK.cactorCoeff (okind cocave $ lkind lvl) > 150 && not (fhasGender $ gplayer fact) ] (oursSeen, oursNotSeen) = partition (fst . snd) oursRaw -- Monster AI changes leadership mostly to move from level -- to level and, in particular, to quickly bring troops -- to the frontline level and so prevent human from killing -- monsters at numerical advantage. -- However, an AI boss that can't move between levels -- distrupts this by hogging leadership. To prevent that, -- assuming the boss resides below the frontline level, -- only the two shallowest levels that are not yet fully -- explored are considered to choose the new leader from. -- This frontier moves as the levels are explored or emptied -- and sometimes the level with the boss is counted among -- them, but it never happens in the crucial periods when -- AI armies are transferred from level to level. f (lid, _) = abs $ fromEnum lid ours = oursSeen ++ take 2 (sortBy (comparing f) oursNotSeen) -- Sole stranded actors tend to become (or stay) leaders -- so that they can join the main force ASAP. let freqList = [ (k, (lid, a)) | (lid, (_, a : rest)) <- ours , let len = 1 + min 7 (length rest) k = 1000000 `div` len ] unless (null freqList) $ do (lid, a) <- rndToAction $ frequency $ toFreq "leadLevel" freqList unless (lid == blid body) $ -- flip levels rather than actors supplantLeader fid a factionD <- getsState sfactionD mapM_ flipFaction $ EM.assocs factionD LambdaHack-0.8.3.0/Game/LambdaHack/Server/ProtocolM.hs0000644000000000000000000002043213315545734020370 0ustar0000000000000000-- | The server definitions for the server-client communication protocol. module Game.LambdaHack.Server.ProtocolM ( -- * The communication channels CliSerQueue, ConnServerDict, ChanServer(..) -- * The server-client communication monad , MonadServerComm ( getsDict -- exposed only to be implemented, not used , modifyDict -- exposed only to be implemented, not used , liftIO -- exposed only to be implemented, not used ) -- * Protocol , putDict, sendUpdate, sendUpdateCheck, sendUpdNoState , sendSfx, sendQueryAI, sendQueryUI -- * Assorted , killAllClients, childrenServer, updateConn, tryRestore #ifdef EXPOSE_INTERNAL -- * Internal operations , writeQueue, readQueueAI, readQueueUI, newQueue #endif ) where import Prelude () import Game.LambdaHack.Common.Prelude import Control.Concurrent import Control.Concurrent.Async import qualified Data.EnumMap.Strict as EM import Data.Key (mapWithKeyM, mapWithKeyM_) import System.FilePath import System.IO.Unsafe (unsafePerformIO) import Game.LambdaHack.Atomic import Game.LambdaHack.Client (RequestAI, RequestUI, Response (..), sbenchmark) import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.File import Game.LambdaHack.Common.Kind import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.MonadStateRead import qualified Game.LambdaHack.Common.Save as Save import Game.LambdaHack.Common.State import Game.LambdaHack.Common.Thread import Game.LambdaHack.Content.ModeKind import Game.LambdaHack.Content.RuleKind import Game.LambdaHack.Server.DebugM import Game.LambdaHack.Server.MonadServer hiding (liftIO) import Game.LambdaHack.Server.ServerOptions import Game.LambdaHack.Server.State writeQueue :: MonadServerComm m => Response -> CliSerQueue Response -> m () {-# INLINE writeQueue #-} writeQueue cmd responseS = liftIO $ putMVar responseS cmd readQueueAI :: MonadServerComm m => CliSerQueue RequestAI -> m RequestAI {-# INLINE readQueueAI #-} readQueueAI requestS = liftIO $ takeMVar requestS readQueueUI :: MonadServerComm m => CliSerQueue RequestUI -> m RequestUI {-# INLINE readQueueUI #-} readQueueUI requestS = liftIO $ takeMVar requestS newQueue :: IO (CliSerQueue a) newQueue = newEmptyMVar type CliSerQueue = MVar -- | Connection information for all factions, indexed by faction identifier. type ConnServerDict = EM.EnumMap FactionId ChanServer -- | Connection channel between the server and a single client. data ChanServer = ChanServer { responseS :: CliSerQueue Response , requestAIS :: CliSerQueue RequestAI , requestUIS :: Maybe (CliSerQueue RequestUI) } -- | The server monad with the ability to communicate with clients. class MonadServer m => MonadServerComm m where getsDict :: (ConnServerDict -> a) -> m a modifyDict :: (ConnServerDict -> ConnServerDict) -> m () liftIO :: IO a -> m a getDict :: MonadServerComm m => m ConnServerDict getDict = getsDict id putDict :: MonadServerComm m => ConnServerDict -> m () putDict s = modifyDict (const s) -- | If the @AtomicFail@ conditions hold, send a command to client, -- otherwise do nothing. sendUpdate :: (MonadServerAtomic m, MonadServerComm m) => FactionId -> UpdAtomic -> m () sendUpdate !fid !cmd = do succeeded <- execUpdAtomicFidCatch fid cmd when succeeded $ sendUpd fid cmd -- | Send a command to client, crashing if the @AtomicFail@ conditions -- don't hold when executed on the client's state. sendUpdateCheck :: (MonadServerAtomic m, MonadServerComm m) => FactionId -> UpdAtomic -> m () sendUpdateCheck !fid !cmd = do execUpdAtomicFid fid cmd sendUpd fid cmd sendUpd :: MonadServerComm m => FactionId -> UpdAtomic -> m () sendUpd !fid !cmd = do chan <- getsDict (EM.! fid) s <- getsServer $ (EM.! fid) . sclientStates let resp = RespUpdAtomic s cmd debug <- getsServer $ sniff . soptions when debug $ debugResponse fid resp writeQueue resp $ responseS chan sendUpdNoState :: MonadServerComm m => FactionId -> UpdAtomic -> m () sendUpdNoState !fid !cmd = do chan <- getsDict (EM.! fid) let resp = RespUpdAtomicNoState cmd debug <- getsServer $ sniff . soptions when debug $ debugResponse fid resp writeQueue resp $ responseS chan sendSfx :: MonadServerComm m => FactionId -> SfxAtomic -> m () sendSfx !fid !sfx = do let resp = RespSfxAtomic sfx debug <- getsServer $ sniff . soptions when debug $ debugResponse fid resp chan <- getsDict (EM.! fid) case chan of ChanServer{requestUIS=Just{}} -> writeQueue resp $ responseS chan _ -> return () sendQueryAI :: MonadServerComm m => FactionId -> ActorId -> m RequestAI sendQueryAI fid aid = do let respAI = RespQueryAI aid debug <- getsServer $ sniff . soptions when debug $ debugResponse fid respAI chan <- getsDict (EM.! fid) req <- do writeQueue respAI $ responseS chan readQueueAI $ requestAIS chan when debug $ debugRequestAI aid return req sendQueryUI :: (MonadServerAtomic m, MonadServerComm m) => FactionId -> ActorId -> m RequestUI sendQueryUI fid _aid = do let respUI = RespQueryUI debug <- getsServer $ sniff . soptions when debug $ debugResponse fid respUI chan <- getsDict (EM.! fid) req <- do writeQueue respUI $ responseS chan readQueueUI $ fromJust $ requestUIS chan when debug $ debugRequestUI _aid return req killAllClients :: (MonadServerAtomic m, MonadServerComm m) => m () killAllClients = do d <- getDict let sendKill fid _ = sendUpdNoState fid $ UpdKillExit fid -- We can't interate over sfactionD, because client can be from an old game. -- For the same reason we can't look up and send client's state. mapWithKeyM_ sendKill d -- Global variable for all children threads of the server. childrenServer :: MVar [Async ()] {-# NOINLINE childrenServer #-} childrenServer = unsafePerformIO (newMVar []) -- | Update connections to the new definition of factions. -- Connect to clients in old or newly spawned threads -- that read and write directly to the channels. updateConn :: (MonadServerAtomic m, MonadServerComm m) => (Bool -> FactionId -> ChanServer -> IO ()) -> m () updateConn executorClient = do -- Prepare connections based on factions. oldD <- getDict let mkChanServer :: Faction -> IO ChanServer mkChanServer fact = do responseS <- newQueue requestAIS <- newQueue requestUIS <- if fhasUI $ gplayer fact then Just <$> newQueue else return Nothing return $! ChanServer{..} addConn :: FactionId -> Faction -> IO ChanServer addConn fid fact = case EM.lookup fid oldD of Just conns -> return conns -- share old conns and threads Nothing -> mkChanServer fact 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 forkUI fid connS = forkChild childrenServer $ executorClient True fid connS forkAI fid connS = forkChild childrenServer $ executorClient False fid connS forkClient fid conn@ChanServer{requestUIS=Nothing} = -- 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 conn forkClient fid conn = forkUI fid conn liftIO $ mapWithKeyM_ forkClient toSpawn tryRestore :: MonadServerComm m => m (Maybe (State, StateServer)) tryRestore = do cops <- getsState scops soptions <- getsServer soptions let bench = sbenchmark $ sclientOptions soptions if bench then return Nothing else do let prefix = ssavePrefixSer soptions fileName = prefix <> Save.saveNameSer cops res <- liftIO $ Save.restoreGame cops fileName let stdRuleset = getStdRuleset cops cfgUIName = rcfgUIName stdRuleset content = rcfgUIDefault stdRuleset dataDir <- liftIO appDataDir liftIO $ tryWriteFile (dataDir cfgUIName) content return $! res LambdaHack-0.8.3.0/Game/LambdaHack/Server/FovDigital.hs0000644000000000000000000002342013315545734020502 0ustar0000000000000000-- | 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.FovDigital ( scan -- * Scanning coordinate system , Bump(..) -- * Assorted minor operations #ifdef EXPOSE_INTERNAL -- * Current scan parameters , Distance, Progress -- * Geometry in system @Bump@ , Line(..), ConvexHull, Edge, EdgeInterval -- * Internal operations , steeper, addHull , dline, dsteeper, intersect, _debugSteeper, _debugLine #endif ) where import Prelude () import Game.LambdaHack.Common.Prelude hiding (intersect) import qualified Data.EnumSet as ES import Game.LambdaHack.Common.Point import qualified Game.LambdaHack.Common.PointArray as PointArray -- | 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) -- | Calculates the list of tiles, in @Bump@ coordinates, visible from (0, 0), -- within the given sight range. scan :: ES.EnumSet Point -> Distance -- ^ visiblity distance -> PointArray.Array Bool -> (Bump -> Point) -- ^ coordinate transformation -> ES.EnumSet Point {-# INLINE scan #-} scan accScan r fovClear tr = assert (r > 0 `blame` r) $ -- The scanned area is a square, which is a sphere in the chessboard metric. dscan accScan 1 ( (Line (B 1 0) (B (-r) r), [B 0 0]) , (Line (B 0 0) (B (r+1) r), [B 1 0]) ) where isClear :: Point -> Bool isClear = (fovClear PointArray.!) dscan :: ES.EnumSet Point -> Distance -> EdgeInterval -> ES.EnumSet Point dscan !accDscan !d ( s0@(!sl{-shallow line-}, !sHull) , e0@(!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 outside = if d < r then let !trBump = bump ps0 !accBump = ES.insert trBump accDscan in if isClear trBump then mscanVisible accBump s0 (ps0+1) -- start visible else mscanShadowed accBump (ps0+1) -- start in shadow else foldl' (\acc ps -> ES.insert (bump ps) acc) accDscan [ps0..pe] bump px = tr $ B px d -- We're in a visible interval. mscanVisible :: ES.EnumSet Point -> Edge -> Progress -> ES.EnumSet Point mscanVisible !acc !s !ps = if ps <= pe then let !trBump = bump ps !accBump = ES.insert trBump acc in if isClear trBump -- not entering shadow then mscanVisible accBump s (ps+1) else let {-# INLINE steepBump #-} steepBump = B ps d cmp :: Bump -> Bump -> Ordering {-# INLINE cmp #-} cmp = flip $ dsteeper steepBump nep = maximumBy cmp (snd s) neHull = addHull cmp steepBump eHull ne = (dline nep steepBump, neHull) accNew = dscan accBump (d+1) (s, ne) in mscanShadowed accNew (ps+1) else dscan acc (d+1) (s, e0) -- reached end, scan next -- We're in a shadowed interval. mscanShadowed :: ES.EnumSet Point -> Progress -> ES.EnumSet Point mscanShadowed !acc !ps = if ps <= pe then let !trBump = bump ps !accBump = ES.insert trBump acc in if not $ isClear trBump -- not moving out of shadow then mscanShadowed accBump (ps+1) else let {-# INLINE shallowBump #-} shallowBump = B ps d cmp :: Bump -> Bump -> Ordering {-# INLINE cmp #-} cmp = dsteeper shallowBump nsp = maximumBy cmp eHull nsHull = addHull cmp shallowBump sHull ns = (dline nsp shallowBump, nsHull) in mscanVisible accBump ns (ps+1) else acc -- reached end while in shadow in assert (r >= d && d >= 0 && pe >= ps0 `blame` (r,d,s0,e0,ps0,pe)) outside -- | 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 -> Ordering {-# INLINE steeper #-} steeper (B xf yf) (B x1 y1) (B x2 y2) = compare ((yf - y2)*(xf - x1)) ((yf - y1)*(xf - x2)) -- | 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 -> Ordering) -- ^ a comparison function -> Bump -- ^ a new bump to consider -> ConvexHull -- ^ a convex hull of bumps represented as a list -> ConvexHull {-# INLINE addHull #-} addHull cmp new = (new :) . go where go (a:b:cs) | cmp b a /= GT = go (b:cs) go l = l -- | 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 -> Ordering {-# INLINE dsteeper #-} dsteeper = \f p1 p2 -> let res = steeper f p1 p2 in #ifdef WITH_EXPENSIVE_ASSERTIONS assert (res == _debugSteeper f p1 p2) #endif res -- | 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 -> Ordering {-# 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 compare (k1 * n2) (n1 * k2) -- | 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.8.3.0/Game/LambdaHack/Server/ItemRev.hs0000644000000000000000000002171013315545734020025 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | Creation of items on the server. Types and operations that don't involve -- server state nor our custom monads. module Game.LambdaHack.Server.ItemRev ( ItemKnown, ItemRev, UniqueSet, buildItem, newItem -- * Item discovery types , DiscoveryKindRev, emptyDiscoveryKindRev, serverDiscos -- * The @FlavourMap@ type , FlavourMap, emptyFlavourMap, dungeonFlavourMap ) where import Prelude () import Game.LambdaHack.Common.Prelude import Data.Binary import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES import qualified Data.HashMap.Strict as HM import Data.Vector.Binary () import qualified Data.Vector.Unboxed as U import qualified Game.LambdaHack.Common.Color as Color import Game.LambdaHack.Common.ContentData import qualified Game.LambdaHack.Common.Dice as Dice import Game.LambdaHack.Common.Flavour import Game.LambdaHack.Common.Frequency import Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.ItemAspect as IA import Game.LambdaHack.Common.Kind import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.Random import Game.LambdaHack.Common.Time import Game.LambdaHack.Content.ItemKind (ItemKind) import qualified Game.LambdaHack.Content.ItemKind as IK -- | 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 them. -- Note 1: @jlid@ is not meaningful; it gets forgotten if items from -- different levels roll the same random properties and so are merged. -- However, the first item generated by the server wins, which in case -- of normal items (not organs), is most of the time the lower absolute -- @jlid@ (shallower depth) item, which makes sense for the client. -- Note 2: item seed instead of @AspectRecord@ is not enough, -- becaused different seeds may result in the same @AspectRecord@ -- and we don't want such items to be distinct in UI and elsewhere. type ItemKnown = (ItemIdentity, IA.AspectRecord, Maybe FactionId) -- | Reverse item map, for item creation, to keep items and item identifiers -- in bijection. type ItemRev = HM.HashMap ItemKnown ItemId type UniqueSet = ES.EnumSet (ContentId ItemKind) -- | Build an item with the given stats. buildItem :: COps -> FlavourMap -> DiscoveryKindRev -> ContentId ItemKind -> ItemKind -> LevelId -> Item buildItem COps{coitem} (FlavourMap flavourMap) (DiscoveryKindRev discoRev) ikChosen kind jlid = let jkind = case IK.getHideAs kind of Just grp -> let kindHidden = ouniqGroup coitem grp in IdentityCovered (toEnum $ fromEnum $ discoRev U.! contentIdIndex ikChosen) kindHidden Nothing -> IdentityObvious ikChosen jfid = Nothing -- the default jflavour = toEnum $ fromEnum $ flavourMap U.! contentIdIndex ikChosen in Item{..} -- | Generate an item based on level. newItem :: COps -> FlavourMap -> DiscoveryKindRev -> UniqueSet -> Freqs ItemKind -> Int -> LevelId -> Dice.AbsDepth -> Dice.AbsDepth -> Rnd (Maybe (ItemKnown, ItemFullKit, GroupName ItemKind)) newItem cops@COps{coitem} flavourMap discoRev uniqueSet itemFreq lvlSpawned lid ldepth@(Dice.AbsDepth ldAbs) totalDepth@(Dice.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 _ _ acc _ ik _ | ik `ES.member` uniqueSet = acc f !itemGroup !q !acc !p !ik !kind = -- Don't consider lvlSpawned for uniques. let ld = if IK.Unique `elem` IK.ifeature kind then ldAbs else ldSpawned rarity = linearInterpolation ld (IK.irarity kind) in (q * p * rarity, ((ik, kind), itemGroup)) : acc g (itemGroup, q) = ofoldlGroup' coitem 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) let itemBase = buildItem cops flavourMap discoRev itemKindId itemKind lid itemIdentity = jkind itemBase itemK = max 1 itemN itemTimer = [timeZero | IK.Periodic `elem` IK.ifeature itemKind] -- delay first discharge of single organs itemSuspect = False -- Bonuses on items/actors unaffected by number of spawned actors. itemAspect <- IA.rollAspectRecord (IK.iaspects itemKind) ldepth totalDepth let itemDisco = ItemDiscoFull {..} itemFull = ItemFull {..} return $ Just ( (itemIdentity, itemAspect, jfid itemBase) , (itemFull, (itemK, itemTimer)) , itemGroup ) -- | The reverse map to @DiscoveryKind@, needed for item creation. -- This is total and never changes, hence implemented as vector. -- Morally, it's indexed by @ContentId ItemKind@ and elements are @ItemKindIx@. newtype DiscoveryKindRev = DiscoveryKindRev (U.Vector Word16) deriving (Show, Binary) emptyDiscoveryKindRev :: DiscoveryKindRev emptyDiscoveryKindRev = DiscoveryKindRev U.empty serverDiscos :: COps -> Rnd (DiscoveryKind, DiscoveryKindRev) serverDiscos COps{coitem} = do let ixs = [toEnum 0..toEnum (olength coitem - 1)] shuffle :: Eq a => [a] -> Rnd [a] shuffle [] = return [] shuffle l = do x <- oneOf l (x :) <$> shuffle (delete x l) shuffled <- shuffle ixs let f (!ikMap, !ikRev, ix : rest) kmKind _ = (EM.insert ix kmKind ikMap, EM.insert kmKind ix ikRev, rest) f (ikMap, _, []) ik _ = error $ "too short ixs" `showFailure` (ik, ikMap) (discoS, discoRev, _) = ofoldlWithKey' coitem f (EM.empty, EM.empty, shuffled) udiscoRev = U.fromListN (olength coitem) $ map (toEnum . fromEnum) $ EM.elems discoRev return (discoS, DiscoveryKindRev udiscoRev) -- | Flavours assigned by the server to item kinds, in this particular game. -- This is total and never changes, hence implemented as vector. -- Morally, it's indexed by @ContentId ItemKind@ and elements are @Flavour@. newtype FlavourMap = FlavourMap (U.Vector Word16) deriving (Show, Binary) emptyFlavourMap :: FlavourMap emptyFlavourMap = FlavourMap U.empty stdFlav :: ES.EnumSet Flavour stdFlav = ES.fromList [ Flavour fn bc | fn <- [minBound..maxBound], bc <- Color.stdCol ] -- | Assigns flavours to item kinds. Assures no flavor is repeated for the same -- symbol, except for items with only one permitted flavour. rollFlavourMap :: Rnd ( EM.EnumMap (ContentId ItemKind) Flavour , EM.EnumMap Char (ES.EnumSet Flavour) ) -> ContentId ItemKind -> ItemKind -> Rnd ( EM.EnumMap (ContentId ItemKind) Flavour , EM.EnumMap Char (ES.EnumSet Flavour) ) rollFlavourMap rnd key ik = case IK.iflavour ik of [] -> error "empty iflavour" [flavour] -> do (!assocs, !availableMap) <- rnd return ( EM.insert key flavour assocs , availableMap) flvs -> do (!assocs, !availableMap) <- rnd let available = EM.findWithDefault stdFlav (IK.isymbol ik) availableMap proper = ES.fromList flvs `ES.intersection` available assert (not (ES.null proper) `blame` "not enough flavours for items" `swith` (flvs, available, ik, availableMap)) $ do flavour <- oneOf $ ES.toList proper let availableReduced = ES.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 :: COps -> Rnd FlavourMap dungeonFlavourMap COps{coitem} = do (assocsFlav, _) <- ofoldlWithKey' coitem rollFlavourMap (return (EM.empty, EM.empty)) let uFlav = U.fromListN (olength coitem) $ map (toEnum . fromEnum) $ EM.elems assocsFlav return $! FlavourMap uFlav LambdaHack-0.8.3.0/Game/LambdaHack/Server/BroadcastAtomic.hs0000644000000000000000000003165713315545734021524 0ustar0000000000000000{-# LANGUAGE TupleSections #-} -- | Sending atomic commands to clients and executing them on the server. -- -- See -- . module Game.LambdaHack.Server.BroadcastAtomic ( handleAndBroadcast, sendPer, handleCmdAtomicServer #ifdef EXPOSE_INTERNAL -- * Internal operations , loudUpdAtomic, loudSfxAtomic, atomicForget, atomicRemember #endif ) where import Prelude () import Game.LambdaHack.Common.Prelude import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES import Data.Key (mapWithKeyM_) import Game.LambdaHack.Atomic import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.Kind import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.MonadStateRead import Game.LambdaHack.Common.Perception 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.TileKind (isUknownSpace) import Game.LambdaHack.Server.MonadServer import Game.LambdaHack.Server.ProtocolM import Game.LambdaHack.Server.ServerOptions import Game.LambdaHack.Server.State --storeUndo :: MonadServer m => CmdAtomic -> m () --storeUndo _atomic = -- maybe skip (\a -> modifyServer $ \ser -> ser {sundo = a : sundo ser}) -- $ Nothing -- undoCmdAtomic atomic handleCmdAtomicServer :: MonadServerAtomic m => UpdAtomic -> m (PosAtomic, [UpdAtomic], Bool) handleCmdAtomicServer cmd = do ps <- posUpdAtomic cmd atomicBroken <- breakUpdAtomic cmd executedOnServer <- if seenAtomicSer ps then execUpdAtomicSer cmd else return False return (ps, atomicBroken, executedOnServer) -- | Send an atomic action to all clients that can see it. handleAndBroadcast :: (MonadServerAtomic m, MonadServerComm m) => PosAtomic -> [UpdAtomic] -> CmdAtomic -> m () handleAndBroadcast ps atomicBroken atomic = do -- This is calculated in the server State before action (simulating -- current client State, because action has not been applied -- on the client yet). -- E.g., actor's position in @breakUpdAtomic@ is assumed to be pre-action. -- To get rid of breakUpdAtomic we'd need to send only Spot and Lose -- commands instead of Move and Displace (plus Sfx for Displace). -- So this only makes sense when we switch to sending state diffs. knowEvents <- getsServer $ sknowEvents . soptions sperFidOld <- getsServer sperFid -- Send some actions to the clients, one faction at a time. let sendAtomic fid (UpdAtomic cmd) = sendUpdate fid cmd sendAtomic fid (SfxAtomic sfx) = sendSfx fid sfx breakSend lid fid fact perFidLid = do -- We take the new leader, from after cmd execution. let hear atomic2 = do local <- case gleader fact of Nothing -> return True -- give leaderless factions some love Just leader -> do body <- getsState $ getActorBody leader return $! (blid body == lid) loud <- case atomic2 of UpdAtomic cmd -> loudUpdAtomic local cmd SfxAtomic cmd -> loudSfxAtomic local cmd case loud of Nothing -> return () Just msg -> sendSfx fid $ SfxMsgFid fid msg send2 (cmd2, ps2) = when (seenAtomicCli knowEvents fid perFidLid ps2) $ sendUpdate fid cmd2 psBroken <- mapM posUpdAtomic atomicBroken case psBroken of _ : _ -> mapM_ send2 $ zip atomicBroken psBroken [] -> hear atomic -- broken commands are never loud -- We assume players perceive perception change before the action, -- so the action is perceived in the new perception, -- even though the new perception depends on the action's outcome -- (e.g., new actor created). anySend lid fid fact perFidLid = if seenAtomicCli knowEvents fid perFidLid ps then sendAtomic fid atomic else breakSend lid fid fact perFidLid posLevel lid fid fact = anySend lid fid fact $ sperFidOld EM.! fid EM.! lid send fid fact = case ps of PosSight lid _ -> posLevel lid fid fact PosFidAndSight _ lid _ -> posLevel lid fid fact PosFidAndSer (Just lid) _ -> posLevel lid fid fact PosSmell lid _ -> posLevel lid fid fact PosFid fid2 -> when (fid == fid2) $ sendAtomic fid atomic PosFidAndSer Nothing fid2 -> when (fid == fid2) $ sendAtomic fid atomic PosSer -> return () PosAll -> sendAtomic fid atomic PosNone -> error $ "" `showFailure` (fid, fact, atomic) -- Factions that are eliminated by the command are processed as well, -- because they are not deleted from @sfactionD@. factionD <- getsState sfactionD mapWithKeyM_ send factionD -- | Messages for some unseen atomic commands. loudUpdAtomic :: MonadStateRead m => Bool -> UpdAtomic -> m (Maybe SfxMsg) loudUpdAtomic local cmd = do COps{coTileSpeedup} <- getsState scops mcmd <- case cmd of UpdDestroyActor _ body _ | not $ bproj body -> return $ Just cmd UpdCreateItem _ _ _ (CActor _ CGround) -> return $ Just cmd UpdTrajectory aid (Just (l, _)) Nothing | local && not (null l) -> do -- Non-blast projectile hits an non-walkable tile on leader's level. b <- getsState $ getActorBody aid itemKind <- getsState $ getIidKindServer (btrunk b) return $! if bproj b && IK.isBlast itemKind then Nothing else Just cmd UpdAlterTile _ _ fromTile _ -> return $! if Tile.isDoor coTileSpeedup fromTile then if local then Just cmd else Nothing else Just cmd UpdAlterExplorable{} -> return $ Just cmd _ -> return Nothing return $! SfxLoudUpd local <$> mcmd -- | Messages for some unseen sfx. loudSfxAtomic :: MonadStateRead m => Bool -> SfxAtomic -> m (Maybe SfxMsg) loudSfxAtomic local cmd = case cmd of SfxStrike _ _ iid _ | local -> do itemKindId <- getsState $ getIidKindIdServer iid let distance = 20 -- TODO: distance to leader; also, add a skill return $ Just $ SfxLoudStrike local itemKindId distance SfxEffect _ aid (IK.Summon grp p) _ | local -> do b <- getsState $ getActorBody aid return $ Just $ SfxLoudSummon (bproj b) grp p _ -> return Nothing sendPer :: (MonadServerAtomic m, MonadServerComm m) => FactionId -> LevelId -> Perception -> Perception -> Perception -> m () {-# INLINE sendPer #-} sendPer fid lid outPer inPer perNew = do knowEvents <- getsServer $ sknowEvents . soptions unless knowEvents $ do -- inconsistencies would quickly manifest sendUpdNoState fid $ UpdPerception lid outPer inPer sClient <- getsServer $ (EM.! fid) . sclientStates let forget = atomicForget fid lid outPer sClient remember <- getsState $ atomicRemember lid inPer sClient let seenNew = seenAtomicCli False fid perNew psRem <- mapM posUpdAtomic remember -- Verify that we remember only currently seen things. let !_A = assert (allB seenNew psRem) () mapM_ (sendUpdateCheck fid) forget mapM_ (sendUpdate fid) remember -- Remembered items, map tiles and smells are not wiped out when they get -- out of FOV. Clients remember them. Only actors are forgotten. atomicForget :: FactionId -> LevelId -> Perception -> State -> [UpdAtomic] atomicForget side lid outPer sClient = -- Wipe out actors that just became invisible due to changed FOV. let outFov = totalVisible outPer outPrio = concatMap (\p -> posToAssocs p lid sClient) $ ES.elems outFov fActor (aid, b) = -- We forget only currently invisible actors. Actors can be outside -- perception, but still visible, if they belong to our faction, -- e.g., if they teleport to outside of current perception -- or if they have disabled senses. if not (bproj b) && bfid b == side then Nothing else Just $ UpdLoseActor aid b $ getCarriedAssocsAndTrunk b sClient -- this command always succeeds, the actor can be always removed, -- because the actor is taken from the state outActor = mapMaybe fActor outPrio in outActor atomicRemember :: LevelId -> Perception -> State -> State -> [UpdAtomic] {-# INLINE atomicRemember #-} atomicRemember lid inPer sClient s = let COps{cotile, coTileSpeedup} = scops s inFov = ES.elems $ totalVisible inPer lvl = sdungeon s EM.! lid -- Wipe out remembered items on tiles that now came into view -- and spot items on these tiles. Optimized away, when items match. lvlClient = sdungeon sClient EM.! lid inContainer allow fc bagEM bagEMClient = let f p = case (EM.lookup p bagEM, EM.lookup p bagEMClient) of (Nothing, Nothing) -> [] -- most common, no items ever (Just bag, Nothing) -> -- common, client unaware let ais = map (\iid -> (iid, getItemBody iid s)) (EM.keys bag) in [UpdSpotItemBag (fc lid p) bag ais | allow p] (Nothing, Just bagClient) -> -- uncommon, all items vanished -- We don't check @allow@, because client sees items there, -- so we assume he's aware of the tile enough to notice. let aisClient = map (\iid -> (iid, getItemBody iid sClient)) (EM.keys bagClient) in [UpdLoseItemBag (fc lid p) bagClient aisClient] (Just bag, Just bagClient) -> -- We don't check @allow@, because client sees items there, -- so we assume he's aware of the tile enough to see new items. if bag == bagClient then [] -- common, nothing has changed, so optimized else -- uncommon, surprise; because it's rare, we send -- whole bags and don't optimize by sending only delta let aisClient = map (\iid -> (iid, getItemBody iid sClient)) (EM.keys bagClient) ais = map (\iid -> (iid, getItemBody iid s)) (EM.keys bag) in [ UpdLoseItemBag (fc lid p) bagClient aisClient , UpdSpotItemBag (fc lid p) bag ais ] in concatMap f inFov inFloor = inContainer (const True) CFloor (lfloor lvl) (lfloor lvlClient) -- Check that client may be shown embedded items, assuming he's not seeing -- any at this position so far. If he's not shown now, the items will be -- revealed via searching the tile later on. -- This check is essential to prevent embedded items from leaking -- tile identity. allowEmbed p = not (Tile.isHideAs coTileSpeedup $ lvl `at` p) || lvl `at` p == lvlClient `at` p inEmbed = inContainer allowEmbed CEmbed (lembed lvl) (lembed lvlClient) -- Spot tiles. atomicTile = -- We ignore the server resending us hidden versions of the tiles -- (or resending us the same data we already got). -- If the tiles are changed to other variants of the hidden tile, -- we can still verify by searching. let f p (loses1, spots1) = let t = lvl `at` p tHidden = fromMaybe t $ Tile.hideAs cotile t tClient = lvlClient `at` p in if tClient `elem` [t, tHidden] then (loses1, spots1) else ( if isUknownSpace tClient then loses1 else (p, tClient) : loses1 , (p, tHidden) : spots1 ) -- send the hidden version (loses, spots) = foldr f ([], []) inFov in [UpdLoseTile lid loses | not $ null loses] ++ [UpdSpotTile lid spots | not $ null spots] -- Wipe out remembered smell on tiles that now came into smell Fov. -- Smell radius is small, so we can just wipe and send all. inSmellFov = ES.elems $ totalSmelled inPer inSm = mapMaybe (\p -> (p,) <$> EM.lookup p (lsmell lvlClient)) inSmellFov inSmell = if null inSm then [] else [UpdLoseSmell lid inSm] -- Spot smells. inSm2 = mapMaybe (\p -> (p,) <$> EM.lookup p (lsmell lvl)) inSmellFov atomicSmell = if null inSm2 then [] else [UpdSpotSmell lid inSm2] -- Actors come last to report the environment they land on. inAssocs = concatMap (\p -> posToAssocs p lid s) inFov -- Here, the actor may be already visible, e.g., when teleporting, -- so the exception is caught in @sendUpdate@ above. fActor (aid, b) = let ais = getCarriedAssocsAndTrunk b s in UpdSpotActor aid b ais inActor = map fActor inAssocs in atomicTile ++ inFloor ++ inEmbed ++ inSmell ++ atomicSmell ++ inActor LambdaHack-0.8.3.0/Game/LambdaHack/Server/HandleEffectM.hs0000644000000000000000000017651213315545734021112 0ustar0000000000000000{-# LANGUAGE TupleSections #-} -- | Handle effects. They are most often caused by requests sent by clients -- but sometimes also caused by projectiles or periodically activated items. module Game.LambdaHack.Server.HandleEffectM ( applyItem, meleeEffectAndDestroy, effectAndDestroy, itemEffectEmbedded , dropCStoreItem, highestImpression, dominateFidSfx, pickDroppable , refillHP, cutCalm #ifdef EXPOSE_INTERNAL -- * Internal operations , UseResult(..) , applyMeleeDamage, imperishableKit, itemEffectDisco, effectSem , effectBurn, effectExplode, effectRefillHP, effectRefillCalm , effectDominate, dominateFid, effectImpress, effectSummon , effectAscend, findStairExit, switchLevels1, switchLevels2, effectEscape , effectParalyze, effectInsertMove, effectTeleport, effectCreateItem , effectDropItem, allGroupItems, effectPolyItem, effectIdentify, identifyIid , effectDetect, effectDetectX , effectSendFlying, sendFlyingVector, effectDropBestWeapon , effectActivateInv, effectTransformContainer, effectApplyPerfume, effectOneOf , effectRecharging, effectTemporary, effectComposite #endif ) where import Prelude () import Game.LambdaHack.Common.Prelude import Data.Bits (xor) import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES import qualified Data.HashMap.Strict as HM import Data.Int (Int64) import Data.Key (mapWithKeyM_) import qualified Data.Ord as Ord 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 qualified Game.LambdaHack.Common.ItemAspect as IA import Game.LambdaHack.Common.Kind import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.MonadStateRead import Game.LambdaHack.Common.Perception import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.Random import Game.LambdaHack.Common.ReqFailure import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile import Game.LambdaHack.Common.Time import Game.LambdaHack.Common.Vector import Game.LambdaHack.Content.ItemKind (ItemKind) import qualified Game.LambdaHack.Content.ItemKind as IK import Game.LambdaHack.Content.ModeKind import Game.LambdaHack.Server.CommonM import Game.LambdaHack.Server.ItemM import Game.LambdaHack.Server.MonadServer import Game.LambdaHack.Server.PeriodicM import Game.LambdaHack.Server.ServerOptions import Game.LambdaHack.Server.State -- * Semantics of effects data UseResult = UseDud | UseId | UseUp deriving (Eq, Ord) applyItem :: MonadServerAtomic m => ActorId -> ItemId -> CStore -> m () applyItem aid iid cstore = do execSfxAtomic $ SfxApply aid iid cstore let c = CActor aid cstore meleeEffectAndDestroy aid aid iid c applyMeleeDamage :: MonadServerAtomic m => ActorId -> ActorId -> ItemId -> m Bool applyMeleeDamage source target iid = do itemKind <- getsState $ getIidKindServer iid if IK.idamage itemKind == 0 then return False else do -- speedup sb <- getsState $ getActorBody source hurtMult <- getsState $ armorHurtBonus source target totalDepth <- getsState stotalDepth Level{ldepth} <- getLevel (blid sb) dmg <- rndToAction $ castDice ldepth totalDepth $ IK.idamage itemKind let rawDeltaHP = fromIntegral hurtMult * xM dmg `divUp` 100 speedDeltaHP = case btrajectory sb of Just (_, speed) -> - modifyDamageBySpeed rawDeltaHP speed Nothing -> - rawDeltaHP if speedDeltaHP < 0 then do -- damage the target, never heal refillHP source target speedDeltaHP return True else return False refillHP :: MonadServerAtomic m => ActorId -> ActorId -> Int64 -> m () refillHP source target speedDeltaHP = assert (speedDeltaHP /= 0) $ do tbOld <- getsState $ getActorBody target ar <- getsState $ getActorAspect target -- We ignore light poison, tiny blasts and similar -1HP per turn annoyances. let serious = speedDeltaHP < minusM && source /= target && not (bproj tbOld) hpMax = IA.aMaxHP ar deltaHP0 | serious = -- if overfull, at least cut back to max min speedDeltaHP (xM hpMax - bhp tbOld) | otherwise = speedDeltaHP deltaHP = if | deltaHP0 > 0 && bhp tbOld > xM 999 -> -- UI limit tenthM -- avoid nop, to avoid loops | deltaHP0 < 0 && bhp tbOld < - xM 999 -> -tenthM | otherwise -> deltaHP0 execUpdAtomic $ UpdRefillHP target deltaHP when serious $ cutCalm target -- If leader just lost all HP, change the leader to let players rescue him, -- especially if he's slowed by the attackers. tb <- getsState $ getActorBody target when (bhp tb <= 0 && bhp tbOld > 0) $ do mleader <- getsState $ gleader . (EM.! bfid tb) . sfactionD when (Just target == mleader) $ do actorD <- getsState sactorD let ours (_, b) = bfid b == bfid tb && not (bproj b) && bhp b > 0 -- Only consider actors with positive HP. positive = filter ours $ EM.assocs actorD onLevel <- getsState $ fidActorRegularIds (bfid tb) (blid tb) case onLevel ++ map fst positive of [] -> return () aid : _ -> execUpdAtomic $ UpdLeadFaction (bfid tb) mleader $ Just aid cutCalm :: MonadServerAtomic m => ActorId -> m () cutCalm target = do tb <- getsState $ getActorBody target ar <- getsState $ getActorAspect target let upperBound = if hpTooLow tb ar then 2 -- to trigger domination on next attack, etc. else xM $ IA.aMaxCalm ar deltaCalm = min minusM1 (upperBound - bcalm tb) -- HP loss decreases Calm by at least @minusM1@ to avoid "hears something", -- which is emitted when decreasing Calm by @minusM@. udpateCalm target deltaCalm -- Here melee damage is applied. This is necessary so that the same -- AI benefit calculation may be used for flinging and for applying items. meleeEffectAndDestroy :: MonadServerAtomic m => ActorId -> ActorId -> ItemId -> Container -> m () meleeEffectAndDestroy source target iid c = do meleePerformed <- applyMeleeDamage source target iid bag <- getsState $ getContainerBag c case iid `EM.lookup` bag of Nothing -> error $ "" `showFailure` (source, target, iid, c) Just kit -> do itemFull <- getsState $ itemToFull iid let IK.ItemKind{IK.ieffects} = itemKind itemFull effectAndDestroy meleePerformed source target iid c False ieffects (itemFull, kit) effectAndDestroy :: MonadServerAtomic m => Bool -> ActorId -> ActorId -> ItemId -> Container -> Bool -> [IK.Effect] -> ItemFullKit -> m () effectAndDestroy meleePerformed _ _ iid container periodic [] (itemFull@ItemFull{itemBase}, kit@(_, itemTimer)) = -- No identification occurs if effects are null. This case is also a speedup. if meleePerformed then do -- melee may cause item destruction let (imperishable, kit2) = imperishableKit True periodic itemTimer itemFull kit unless imperishable $ execUpdAtomic $ UpdLoseItem False iid itemBase kit2 container else return () effectAndDestroy meleePerformed source target iid container periodic effs ( itemFull@ItemFull{itemBase, itemDisco, itemKind} , kit@(itemK, itemTimer) ) = do let timeout = IA.aTimeout $ itemAspect itemDisco permanent = let tmpEffect :: IK.Effect -> Bool tmpEffect IK.Temporary{} = True tmpEffect (IK.Recharging IK.Temporary{}) = True tmpEffect (IK.OnSmash IK.Temporary{}) = True tmpEffect _ = False in not $ any tmpEffect effs lid <- getsState $ lidFromC container localTime <- getsState $ getLocalTime lid let it1 = let timeoutTurns = timeDeltaScale (Delta timeTurn) timeout charging startT = timeShift startT timeoutTurns > localTime in filter charging itemTimer len = length it1 recharged = len < itemK it2 = if timeout /= 0 && recharged then if periodic && not permanent -- copies are spares only then replicate (itemK - length it1) localTime ++ it1 else localTime : it1 -- copies all fire, in turn else itemTimer !_A = assert (len <= itemK `blame` (source, target, iid, container)) () -- We use up the charge even if eventualy every effect fizzles. Tough luck. -- At least we don't destroy the item in such case. Also, we ID it regardless. unless (itemTimer == it2) $ execUpdAtomic $ UpdTimeItem iid container itemTimer it2 -- If the activation is not periodic, trigger at least the effects -- that are not recharging and so don't depend on @recharged@. -- Also, if the item was meleed with, let it get destroyed, if perishable, -- and let it get identified, even if no effect was eventually triggered. -- Otherwise don't even id the item --- no risk of destruction, no id. when (not periodic || recharged || meleePerformed) $ 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 (imperishable, kit2) = imperishableKit permanent periodic it2 itemFull kit unless imperishable $ execUpdAtomic $ UpdLoseItem False iid itemBase kit2 container -- At this point, the item is potentially no longer in container @c@, -- so we don't pass @c@ along. triggeredEffect <- itemEffectDisco source target iid itemKind container recharged periodic effs let triggered = if meleePerformed then UseUp else triggeredEffect sb <- getsState $ getActorBody source -- Announce no effect, which is rare and wastes time, so noteworthy. unless (triggered == UseUp -- effects triggered; feedback comes from them || periodic -- don't spam via fizzled periodic effects || bproj sb -- don't spam, projectiles can be very numerous ) $ execSfxAtomic $ SfxMsgFid (bfid sb) $ if any IK.forApplyEffect effs then SfxFizzles -- something didn't work, despite promising effects else SfxNothingHappens -- fully expected -- 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 == UseUp || imperishable) $ execUpdAtomic $ UpdSpotItem False iid itemBase kit2 container imperishableKit :: Bool -> Bool -> ItemTimer -> ItemFull -> ItemQuant -> (Bool, ItemQuant) imperishableKit permanent periodic it2 ItemFull{itemKind} (itemK, _) = let fragile = IK.Fragile `elem` IK.ifeature itemKind durable = IK.Durable `elem` IK.ifeature itemKind imperishable = durable && not fragile || periodic && permanent kit = if permanent || periodic then (1, take 1 it2) else (itemK, it2) in (imperishable, kit) -- The item is triggered exactly once. If there are more copies, -- they are left to be triggered next time. itemEffectEmbedded :: MonadServerAtomic m => ActorId -> LevelId -> Point -> ItemId -> m () itemEffectEmbedded aid lid tpos iid = do -- First embedded item may move actor to another level, so @lid@ -- may be unequal to @blid sb@. let c = CEmbed lid tpos meleeEffectAndDestroy aid aid iid c -- | The source actor affects the target actor, with a given item. -- If any of the effects fires up, the item gets identified. -- Note that using raw damage (beating the enemy with the magic wand, -- for example) does not identify the item. -- -- Note that if we activate a durable item, e.g., armor, from the ground, -- it will get identified, which is perfectly fine, until we want to add -- sticky armor that can't be easily taken off (and, e.g., has some maluses). itemEffectDisco :: MonadServerAtomic m => ActorId -> ActorId -> ItemId -> ItemKind -> Container -> Bool -> Bool -> [IK.Effect] -> m UseResult itemEffectDisco source target iid itemKind c recharged periodic effs = do urs <- mapM (effectSem source target iid c recharged periodic) effs let ur = case urs of [] -> UseDud _ -> maximum urs -- Note: @UseId@ suffices for identification, @UseUp@ is not necessary. when (ur >= UseId && not (IK.onlyMinorEffects itemKind)) $ do kindId <- getsState $ getIidKindIdServer iid discoAspect <- getsState sdiscoAspect execUpdAtomic $ UpdDiscover c iid kindId $ discoAspect EM.! iid return ur -- | 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 :: MonadServerAtomic m => ActorId -> ActorId -> ItemId -> Container -> Bool -> Bool -> IK.Effect -> m UseResult effectSem source target iid c recharged periodic effect = do let recursiveCall = effectSem source target iid c recharged periodic sb <- getsState $ getActorBody source pos <- getsState $ posFromC c -- @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 0 case effect of IK.Burn nDm -> effectBurn nDm source target IK.Explode t -> effectExplode execSfx t target IK.RefillHP p -> effectRefillHP p source target IK.RefillCalm p -> effectRefillCalm execSfx p source target IK.Dominate -> effectDominate source target IK.Impress -> effectImpress recursiveCall execSfx source target IK.Summon grp nDm -> effectSummon grp nDm iid source target periodic IK.Ascend p -> effectAscend recursiveCall execSfx p source target pos IK.Escape{} -> effectEscape source target IK.Paralyze nDm -> effectParalyze execSfx nDm source target IK.InsertMove nDm -> effectInsertMove execSfx nDm source target IK.Teleport nDm -> effectTeleport execSfx nDm source target IK.CreateItem store grp tim -> effectCreateItem (Just $ bfid sb) Nothing target store grp tim IK.DropItem n k store grp -> effectDropItem execSfx n k store grp target IK.PolyItem -> effectPolyItem execSfx source target IK.Identify -> effectIdentify execSfx iid source target IK.Detect d radius -> effectDetect execSfx d radius target pos 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 UseDud -- ignored under normal circumstances IK.Recharging e -> effectRecharging recursiveCall e recharged IK.Temporary _ -> effectTemporary execSfx source iid c IK.Composite l -> effectComposite recursiveCall l -- * Individual semantic functions for effects -- ** Burn -- Damage from fire. Not affected by armor. effectBurn :: MonadServerAtomic m => Dice.Dice -> ActorId -> ActorId -> m UseResult effectBurn nDm source target = do tb <- getsState $ getActorBody target totalDepth <- getsState stotalDepth Level{ldepth} <- getLevel (blid tb) n0 <- rndToAction $ castDice ldepth totalDepth nDm let n = max 1 n0 -- avoid 0 and negative burn deltaHP = - xM n sb <- getsState $ getActorBody source -- Display the effect more accurately. let reportedEffect = IK.Burn $ Dice.intToDice n execSfxAtomic $ SfxEffect (bfid sb) target reportedEffect deltaHP refillHP source target deltaHP return UseUp -- ** Explode effectExplode :: MonadServerAtomic m => m () -> GroupName ItemKind -> ActorId -> m UseResult effectExplode execSfx cgroup target = do execSfx tb <- getsState $ getActorBody target let itemFreq = [(cgroup, 1)] -- Explosion particles are placed among organs of the victim: container = CActor target COrgan m2 <- rollAndRegisterItem (blid tb) itemFreq container False Nothing let (iid, ((ItemFull{itemBase}, (itemK, _)), _)) = fromMaybe (error $ "" `showFailure` cgroup) m2 Point x y = bpos tb semirandom = case jkind itemBase of IdentityObvious ik -> fromEnum ik IdentityCovered ix _ -> fromEnum ix 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 veryrandom = (k100 `xor` (semirandom + n)) `mod` 5 fuzz = 5 + veryrandom k | itemK >= 8 && n < 4 = 0 -- speed up if only a handful remains | n < 16 && n >= 12 = 12 | n < 12 && n >= 8 = 8 | n < 8 && n >= 4 = 4 | otherwise = min n 16 -- fire in groups of 16 including old duds psDir4 = [ Point (x - 12) (y + 12) , Point (x + 12) (y + 12) , Point (x - 12) (y - 12) , Point (x + 12) (y - 12) ] psDir8 = [ Point (x - 12) y , Point (x + 12) y , Point x (y + 12) , Point x (y - 12) ] psFuzz = [ Point (x - 12) $ y + fuzz , Point (x + 12) $ y + fuzz , Point (x - 12) $ y - fuzz , Point (x + 12) $ y - fuzz , flip Point (y - 12) $ x + fuzz , flip Point (y + 12) $ x + fuzz , flip Point (y - 12) $ x - fuzz , flip Point (y + 12) $ x - fuzz ] semireverse = if semirandom `mod` 2 == 0 then id else reverse ps = take k $ concat $ semireverse [ zip (repeat True) -- diagonal particles don't reach that far $ take 4 (drop ((k100 + itemK + fuzz) `mod` 4) $ cycle psDir4) , zip (repeat False) -- only some cardinal reach far $ take 4 (drop ((k100 + n) `mod` 4) $ cycle psDir8) ] ++ [zip (repeat True) $ take 8 (drop ((k100 + fuzz) `mod` 8) $ cycle psFuzz)] forM_ ps $ \(centerRaw, tpxy) -> do let center = centerRaw && itemK >= 8 -- if few, keep them regular mfail <- projectFail target tpxy veryrandom center iid COrgan True case mfail of Nothing -> return () Just ProjectBlockTerrain -> return () Just ProjectBlockActor | not $ bproj tb -> return () Just failMsg -> execSfxAtomic $ SfxMsgFid (bfid tb) $ SfxUnexpected failMsg tryFlying 0 = return () tryFlying k100 = do -- Explosion particles are placed among organs of the victim: bag2 <- getsState $ borgan . getActorBody target let mn2 = EM.lookup iid bag2 case mn2 of Nothing -> return () Just n2 -> do projectN k100 n2 tryFlying $ k100 - 1 -- Particles that fail to take off, bounce off obstacles up to 100 times -- in total, trying to fly in different directions. tryFlying 100 bag3 <- getsState $ borgan . getActorBody target let mn3 = EM.lookup iid bag3 -- Give up and destroy the remaining particles, if any. maybe (return ()) (\kit -> execUpdAtomic $ UpdLoseItem False iid itemBase kit container) mn3 return UseUp -- we neglect verifying that at least one projectile got off -- ** RefillHP -- Unaffected by armor. effectRefillHP :: MonadServerAtomic m => Int -> ActorId -> ActorId -> m UseResult effectRefillHP power0 source target = do sb <- getsState $ getActorBody source tb <- getsState $ getActorBody target curChalSer <- getsServer $ scurChalSer . soptions fact <- getsState $ (EM.! bfid tb) . sfactionD let power = if power0 <= -1 then power0 else max 1 power0 -- avoid 0 deltaHP = xM power if | cfish curChalSer && deltaHP > 0 && fhasUI (gplayer fact) && bfid sb /= bfid tb -> do execSfxAtomic $ SfxMsgFid (bfid tb) SfxColdFish return UseId | otherwise -> do let reportedEffect = IK.RefillHP power execSfxAtomic $ SfxEffect (bfid sb) target reportedEffect deltaHP refillHP source target deltaHP return UseUp -- ** RefillCalm effectRefillCalm :: MonadServerAtomic m => m () -> Int -> ActorId -> ActorId -> m UseResult effectRefillCalm execSfx power0 source target = do tb <- getsState $ getActorBody target ar <- getsState $ getActorAspect target let power = if power0 <= -1 then power0 else max 1 power0 -- avoid 0 rawDeltaCalm = xM power calmMax = IA.aMaxCalm ar serious = rawDeltaCalm < minusM && source /= target && not (bproj tb) deltaCalm0 | serious = -- if overfull, at least cut back to max min rawDeltaCalm (xM calmMax - bcalm tb) | otherwise = rawDeltaCalm deltaCalm = if | deltaCalm0 > 0 && bcalm tb > xM 999 -> -- UI limit tenthM -- avoid nop, to avoid loops | deltaCalm0 < 0 && bcalm tb < - xM 999 -> -tenthM | otherwise -> deltaCalm0 execSfx udpateCalm target deltaCalm return UseUp -- ** Dominate effectDominate :: MonadServerAtomic m => ActorId -> ActorId -> m UseResult effectDominate source target = do sb <- getsState $ getActorBody source tb <- getsState $ getActorBody target if | bproj tb -> return UseDud | bfid tb == bfid sb -> return UseDud -- accidental hit; ignore | otherwise -> do fact <- getsState $ (EM.! bfid tb) . sfactionD hiImpression <- highestImpression target permitted <- if fleaderMode (gplayer fact) == LeaderNull -- To tame/hack animal/robot, you need to impress them first. && hiImpression /= Just (bfid sb) then do execSfxAtomic $ SfxMsgFid (bfid sb) $ SfxUnimpressed target return False else return True if permitted then do b <- dominateFidSfx target (bfid sb) return $! if b then UseUp else UseDud else return UseDud highestImpression :: MonadServerAtomic m => ActorId -> m (Maybe FactionId) highestImpression target = do tb <- getsState $ getActorBody target getKind <- getsState $ flip getIidKindServer getItem <- getsState $ flip getItemBody let isImpression iid = maybe False (> 0) $ lookup "impressed" $ IK.ifreq $ getKind iid impressions = EM.filterWithKey (\iid _ -> isImpression iid) $ borgan tb f (_, (k, _)) = k maxImpression = maximumBy (Ord.comparing f) $ EM.assocs impressions if EM.null impressions then return Nothing else case jfid $ getItem $ fst maxImpression of Nothing -> return Nothing Just fid -> assert (fid /= bfid tb) $ return $ Just fid dominateFidSfx :: MonadServerAtomic m => ActorId -> FactionId -> m Bool dominateFidSfx target fid = 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. Also, they are a hassle to guide through the dungeon. canTra <- getsState $ canTraverse target if canTra && not (bproj tb) && bhp tb > 0 then do let execSfx = execSfxAtomic $ SfxEffect fid target IK.Dominate 0 execSfx -- if actor ours, possibly the last occasion to see him gameOver <- dominateFid fid target unless gameOver -- avoid spam execSfx -- see the actor as theirs, unless position not visible return True else return False dominateFid :: MonadServerAtomic m => FactionId -> ActorId -> m Bool dominateFid fid target = do tb0 <- getsState $ getActorBody target -- At this point the actor's body exists and his items are not dropped. deduceKilled 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 False target CSha CInv tb <- getsState $ getActorBody target ais <- getsState $ getCarriedAssocsAndTrunk tb ar <- getsState $ getActorAspect target getKind <- getsState $ flip getIidKindServer let isImpression iid = maybe False (> 0) $ lookup "impressed" $ IK.ifreq $ getKind iid dropAllImpressions = EM.filterWithKey (\iid _ -> not $ isImpression iid) borganNoImpression = dropAllImpressions $ borgan tb btime <- getsServer $ (EM.! target) . (EM.! blid tb) . (EM.! bfid tb) . sactorTime execUpdAtomic $ UpdLoseActor target tb ais let bNew = tb { bfid = fid , bcalm = max (xM 10) $ xM (IA.aMaxCalm ar) `div` 2 , bhp = min (xM $ IA.aMaxHP ar) $ bhp tb + xM 10 , borgan = borganNoImpression} aisNew <- getsState $ getCarriedAssocsAndTrunk bNew modifyServer $ \ser -> ser {sactorTime = updateActorTime fid (blid tb) target btime $ sactorTime ser} execUpdAtomic $ UpdSpotActor target bNew aisNew factionD <- getsState sfactionD let inGame fact2 = case gquit fact2 of Nothing -> True Just Status{stOutcome=Camping} -> True _ -> False gameOver = not $ any inGame $ EM.elems factionD if gameOver then return True -- avoid spam identifying item at this point else do -- Add some nostalgia for the old faction. void $ effectCreateItem (Just $ bfid tb) (Just 10) target COrgan "impressed" IK.timerNone getKindId <- getsState $ flip getIidKindIdServer let discoverIf (iid, cstore) = do let itemKindId = getKindId iid c = CActor target cstore -- We avoid forcing the dominated actor to drop all items, -- so they are not picked up by the new controllers, so id them here. discoverIfMinorEffects c iid itemKindId aic = (btrunk tb, if bproj tb then CEqp else COrgan) : filter ((/= btrunk tb) . fst) (getCarriedIidCStore tb) mapM_ discoverIf aic -- Focus on the dominated actor, by making him a leader. supplantLeader fid target return False -- ** Impress effectImpress :: MonadServerAtomic m => (IK.Effect -> m UseResult) -> m () -> ActorId -> ActorId -> m UseResult effectImpress recursiveCall execSfx source target = do sb <- getsState $ getActorBody source tb <- getsState $ getActorBody target if | bproj tb -> return UseDud | bfid tb == bfid sb -> -- Unimpress wrt others, but only once. The recursive Sfx suffices. recursiveCall $ IK.DropItem 1 1 COrgan "impressed" | otherwise -> do -- Actors that don't move freely and so are stupid, can't be impressed. canTra <- getsState $ canTraverse target if canTra then do unless (bhp tb <= 0) execSfx -- avoid spam just before death effectCreateItem (Just $ bfid sb) (Just 1) target COrgan "impressed" IK.timerNone else return UseDud -- no message, because common and not crucial -- ** Summon -- Note that the Calm expended doesn't depend on the number of actors summoned. effectSummon :: MonadServerAtomic m => GroupName ItemKind -> Dice.Dice -> ItemId -> ActorId -> ActorId -> Bool -> m UseResult effectSummon grp nDm iid source target periodic = do -- Obvious effect, nothing announced. COps{coTileSpeedup} <- getsState scops sb <- getsState $ getActorBody source tb <- getsState $ getActorBody target actorAspect <- getsState sactorAspect totalDepth <- getsState stotalDepth Level{ldepth} <- getLevel (blid tb) itemKind <- getsState $ getIidKindServer iid power0 <- rndToAction $ castDice ldepth totalDepth nDm let power = max power0 1 -- KISS, always at least one summon -- We put @source@ instead of @target@ and @power@ instead of dice -- to make the message more accurate. effect = IK.Summon grp $ Dice.intToDice power execSfx = execSfxAtomic $ SfxEffect (bfid sb) source effect 0 sar = actorAspect EM.! source tar = actorAspect EM.! target durable = IK.Durable `elem` IK.ifeature itemKind deltaCalm = - xM 30 -- Verify Calm only at periodic activations or if the item is durable. -- Otherwise summon uses up the item, which prevents summoning getting -- out of hand. I don't verify Calm otherwise, to prevent an exploit -- via draining one's calm on purpose when an item with good activation -- has a nasty summoning side-effect (the exploit still works on durables). if | (periodic || durable) && not (bproj sb) && (bcalm sb < - deltaCalm || not (calmEnough sb sar)) -> do unless (bproj sb) $ execSfxAtomic $ SfxMsgFid (bfid sb) $ SfxSummonLackCalm source return UseId | otherwise -> do execSfx unless (bproj sb) $ udpateCalm source deltaCalm let validTile t = not $ Tile.isNoActor coTileSpeedup t ps <- getsState $ nearbyFreePoints validTile (bpos tb) (blid tb) localTime <- getsState $ getLocalTime (blid tb) -- Make sure summoned actors start acting after the victim. let actorTurn = ticksPerMeter $ momentarySpeed tb tar targetTime = timeShift localTime actorTurn afterTime = timeShift targetTime $ Delta timeClip bs <- forM (take power ps) $ \p -> do -- Mark as summoned to prevent immediate chain summoning. maid <- addAnyActor True [(grp, 1)] (blid tb) afterTime (Just p) case maid of Nothing -> return False -- not enough space in dungeon? Just aid -> do b <- getsState $ getActorBody aid mleader <- getsState $ gleader . (EM.! bfid b) . sfactionD when (isNothing mleader) $ supplantLeader (bfid b) aid return True return $! if or bs then UseUp else UseId -- ** Ascend -- Note that projectiles can be teleported, too, for extra fun. effectAscend :: MonadServerAtomic m => (IK.Effect -> m UseResult) -> m () -> Bool -> ActorId -> ActorId -> Point -> m UseResult effectAscend recursiveCall execSfx up source target pos = do b1 <- getsState $ getActorBody target let lid1 = blid b1 (lid2, pos2) <- getsState $ whereTo lid1 pos (Just up) . sdungeon sb <- getsState $ getActorBody source if | braced b1 -> do execSfxAtomic $ SfxMsgFid (bfid sb) $ SfxBracedImmune target return UseId | lid2 == lid1 && pos2 == pos -> do execSfxAtomic $ SfxMsgFid (bfid sb) SfxLevelNoMore -- We keep it useful even in shallow dungeons. recursiveCall $ IK.Teleport 30 -- powerful teleport | otherwise -> do execSfx btime_bOld <- getsServer $ (EM.! target) . (EM.! lid1) . (EM.! bfid b1) . sactorTime pos3 <- findStairExit (bfid sb) up lid2 pos2 let switch1 = void $ switchLevels1 (target, b1) switch2 = do -- Make the initiator of the stair move the leader, -- to let him clear the stairs for others to follow. let mlead = if bproj b1 then Nothing else Just target -- Move the actor to where the inhabitants were, if any. switchLevels2 lid2 pos3 (target, b1) btime_bOld mlead -- The actor will be added to the new level, -- but there can be other actors at his new position. inhabitants <- getsState $ posToAssocs pos3 lid2 case inhabitants of [] -> do switch1 switch2 (_, b2) : _ -> do -- Alert about the switch. -- Only tell one player, even if many actors, because then -- they are projectiles, so not too important. execSfxAtomic $ SfxMsgFid (bfid b2) SfxLevelPushed -- Move the actor out of the way. switch1 -- Move the inhabitants out of the way and to where the actor was. let moveInh inh = do -- Preserve the old leader, since the actor is pushed, -- so possibly has nothing worhwhile to do on the new level -- (and could try to switch back, if made a leader, -- leading to a loop). btime_inh <- getsServer $ (EM.! fst inh) . (EM.! lid2) . (EM.! bfid (snd inh)) . sactorTime inhMLead <- switchLevels1 inh switchLevels2 lid1 (bpos b1) inh btime_inh inhMLead mapM_ moveInh inhabitants -- Move the actor to his destination. switch2 return UseUp findStairExit :: MonadStateRead m => FactionId -> Bool -> LevelId -> Point -> m Point findStairExit side moveUp lid pos = do COps{coTileSpeedup} <- getsState scops fact <- getsState $ (EM.! side) . sfactionD lvl <- getLevel lid let defLanding = uncurry Vector $ if moveUp then (1, 0) else (-1, 0) center = uncurry Vector $ if moveUp then (-1, 0) else (1, 0) (mvs2, mvs1) = break (== defLanding) moves mvs = center : filter (/= center) (mvs1 ++ mvs2) ps = filter (Tile.isWalkable coTileSpeedup . (lvl `at`)) $ map (shift pos) mvs posOcc :: State -> Int -> Point -> Bool posOcc s k p = case posToAssocs p lid s of [] -> k == 0 (_, b) : _ | bproj b -> k == 3 (_, b) : _ | isFoe side fact (bfid b) -> k == 1 -- non-proj foe _ -> k == 2 -- moving a non-projectile friend unocc <- getsState posOcc case concatMap (\k -> filter (unocc k) ps) [0..3] of [] -> error $ "" `showFailure` ps posRes : _ -> return posRes switchLevels1 :: MonadServerAtomic m => (ActorId, Actor) -> m (Maybe ActorId) switchLevels1 (aid, bOld) = do let side = bfid bOld mleader <- getsState $ gleader . (EM.! side) . sfactionD -- Prevent leader pointing to a non-existing actor. mlead <- if not (bproj bOld) && isJust mleader then do execUpdAtomic $ UpdLeadFaction side mleader Nothing return mleader -- outside of a client we don't know the real tgt of aid, hence fst else return Nothing -- Remove the actor from the old level. -- Onlookers see somebody disappear suddenly. -- @UpdDestroyActor@ is too loud, so use @UpdLoseActor@ instead. ais <- getsState $ getCarriedAssocsAndTrunk bOld execUpdAtomic $ UpdLoseActor aid bOld ais return mlead switchLevels2 ::MonadServerAtomic m => LevelId -> Point -> (ActorId, Actor) -> Time -> Maybe ActorId -> m () switchLevels2 lidNew posNew (aid, bOld) btime_bOld mlead = do let lidOld = blid bOld side = bfid bOld let !_A = assert (lidNew /= lidOld `blame` "stairs looped" `swith` lidNew) () -- Sync actor's items' timeouts with the new local time of the level. -- We need to sync organs and equipment due to periodic activations, -- but also inventory pack (as well as some organs and equipment), -- due to timeouts after use, e.g., for some weapons (they recharge also -- in the pack; however, this doesn't encourage micromanagement for periodic -- items, because the timeout is randomised upon move to equipment). -- -- We don't rebase timeouts for items in stash, because they are -- used by many actors on levels with different local times, -- so there is no single rebase that would match all. -- This is not a big problem: after a single use by an actor the timeout is -- set to his current local time, so further uses by that actor have -- not anomalously short or long recharge times. If the recharge time -- is very long, the player has an option of moving the item from stash -- to pack and back, to reset the timeout. An abuse is possible when recently -- used item is put from inventory to stash and at once used on another level -- taking advantage of local time difference, but this only works once -- and using the item back again at the original level makes the recharge -- time longer, in turn. timeOld <- getsState $ getLocalTime lidOld timeLastActive <- getsState $ getLocalTime lidNew let delta = timeLastActive `timeDeltaToFrom` timeOld shiftByDelta = (`timeShift` delta) computeNewTimeout :: ItemQuant -> ItemQuant computeNewTimeout (k, it) = (k, map shiftByDelta it) rebaseTimeout :: ItemBag -> ItemBag rebaseTimeout = EM.map computeNewTimeout bNew = bOld { blid = lidNew , bpos = posNew , boldpos = Just posNew -- new level, new direction , borgan = rebaseTimeout $ borgan bOld , beqp = rebaseTimeout $ beqp bOld , binv = rebaseTimeout $ binv bOld } ais <- getsState $ getCarriedAssocsAndTrunk bOld -- Sync the actor time with the level time. -- This time shift may cause a double move of a foe of the same speed, -- but this is OK --- the foe didn't have a chance to move -- before, because the arena went inactive, so he moves now one more time. let btime = shiftByDelta btime_bOld modifyServer $ \ser -> ser {sactorTime = updateActorTime (bfid bNew) lidNew aid btime $ sactorTime ser} -- Materialize the actor at the new location. -- Onlookers see somebody appear suddenly. The actor himself -- sees new surroundings and has to reset his perception. execUpdAtomic $ UpdCreateActor aid bNew ais case mlead of Nothing -> return () Just leader -> supplantLeader side leader -- ** Escape -- | The faction leaves the dungeon. effectEscape :: MonadServerAtomic m => ActorId -> ActorId -> m UseResult 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 -> return UseDud -- basically a misfire | not (fcanEscape $ gplayer fact) -> do execSfxAtomic $ SfxMsgFid (bfid sb) SfxEscapeImpossible return UseId | otherwise -> do deduceQuits (bfid b) $ Status Escape (fromEnum $ blid b) Nothing return UseUp -- ** Paralyze -- | Advance target actor time by this many time clips. Not by actor moves, -- to hurt fast actors more. effectParalyze :: MonadServerAtomic m => m () -> Dice.Dice -> ActorId -> ActorId -> m UseResult effectParalyze execSfx nDm source target = do tb <- getsState $ getActorBody target totalDepth <- getsState stotalDepth Level{ldepth} <- getLevel (blid tb) actorStasis <- getsServer sactorStasis power0 <- rndToAction $ castDice ldepth totalDepth nDm let power = max power0 1 -- KISS, avoid special case t = timeDeltaScale (Delta timeClip) power if | bproj tb -> return UseDud | ES.member target actorStasis -> do sb <- getsState $ getActorBody source execSfxAtomic $ SfxMsgFid (bfid sb) SfxStasisProtects return UseId | otherwise -> do execSfx modifyServer $ \ser -> ser { sactorTime = ageActor (bfid tb) (blid tb) target t $ sactorTime ser , sactorStasis = ES.insert target (sactorStasis ser) } -- actor's time warped, so he is in stasis, -- immune to further warps return UseUp -- ** 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 :: MonadServerAtomic m => m () -> Dice.Dice -> ActorId -> ActorId -> m UseResult effectInsertMove execSfx nDm source target = do tb <- getsState $ getActorBody target ar <- getsState $ getActorAspect target totalDepth <- getsState stotalDepth Level{ldepth} <- getLevel (blid tb) actorStasis <- getsServer sactorStasis power0 <- rndToAction $ castDice ldepth totalDepth nDm let power = max power0 1 -- KISS, avoid special case actorTurn = ticksPerMeter $ momentarySpeed tb ar t = timeDeltaScale actorTurn (-power) -- Projectiles permitted; can't be suspended mid-air, as in @effectParalyze@ -- but can be propelled. if | ES.member target actorStasis -> do sb <- getsState $ getActorBody source execSfxAtomic $ SfxMsgFid (bfid sb) SfxStasisProtects return UseId | otherwise -> do execSfx modifyServer $ \ser -> ser { sactorTime = ageActor (bfid tb) (blid tb) target t $ sactorTime ser , sactorStasis = ES.insert target (sactorStasis ser) } -- actor's time warped, so he is in stasis, -- immune to further warps return UseUp -- ** Teleport -- | Teleport the target actor. -- Note that projectiles can be teleported, too, for extra fun. effectTeleport :: MonadServerAtomic m => m () -> Dice.Dice -> ActorId -> ActorId -> m UseResult effectTeleport execSfx nDm source target = do COps{coTileSpeedup} <- getsState scops sb <- getsState $ getActorBody source tb <- getsState $ getActorBody target totalDepth <- getsState stotalDepth lvl@Level{ldepth, ltile} <- getLevel (blid tb) range <- rndToAction $ castDice ldepth totalDepth nDm let spos = bpos tb dMinMax delta pos = let d = chessDist spos pos in d >= range - delta && d <= range + delta dist delta pos _ = dMinMax delta pos tpos <- rndToAction $ findPosTry 200 ltile (\p t -> Tile.isWalkable coTileSpeedup t && (not (dMinMax 9 p) -- don't loop, very rare || not (Tile.isNoActor coTileSpeedup t) && null (posToAidsLvl p lvl))) [ dist 1 , dist $ 1 + range `div` 9 , dist $ 1 + range `div` 7 , dist $ 1 + range `div` 5 , dist 5 , dist 7 , dist 9 ] if | braced tb -> do execSfxAtomic $ SfxMsgFid (bfid sb) $ SfxBracedImmune target return UseId | not (dMinMax 9 tpos) -> do -- very rare execSfxAtomic $ SfxMsgFid (bfid sb) SfxTransImpossible return UseId | otherwise -> do execSfx execUpdAtomic $ UpdMoveActor target spos tpos return UseUp -- ** CreateItem effectCreateItem :: MonadServerAtomic m => Maybe FactionId -> Maybe Int -> ActorId -> CStore -> GroupName ItemKind -> IK.TimerDice -> m UseResult effectCreateItem jfidRaw mcount target store grp tim = do tb <- getsState $ getActorBody target totalDepth <- getsState stotalDepth Level{ldepth} <- getLevel (blid tb) let fscale unit nDm = do k0 <- rndToAction $ castDice ldepth totalDepth nDm let k = max 1 k0 -- KISS, don't freak out if dice permit 0 return $! timeDeltaScale unit k fgame = fscale (Delta timeTurn) factor nDm = do ar <- getsState $ getActorAspect target -- A tiny bit added to make sure length 1 effect doesn't end before -- the end of first turn, which would make, e.g., speed, useless. let actorTurn = timeDeltaPercent (ticksPerMeter $ momentarySpeed tb ar) 101 fscale actorTurn nDm delta <- IK.foldTimer (return $ Delta timeZero) fgame factor tim let c = CActor target store bagBefore <- getsState $ getBodyStoreBag tb store let litemFreq = [(grp, 1)] -- Power depth of new items unaffected by number of spawned actors. m3 <- rollItem 0 (blid tb) litemFreq let (itemKnownRaw, (itemFullRaw, kitRaw), _) = fromMaybe (error $ "" `showFailure` (blid tb, litemFreq, c)) m3 -- Avoid too many different item identifiers (one for each faction) -- for blasts or common item generating tiles. Temporary organs are -- allowed to be duplicated, because they provide really useful info -- (perpetrator). However, if timer is none, they are not duplicated -- to make sure that, e.g., poisons stack with each other regardless -- of perpetrator and we don't get "no longer poisoned" message -- while still poisoned due to another faction. With timed aspects, -- e.g., slowness, the message is less misleading, and it's interesting -- that I'm twice slower due to aspects from two factions and not -- as deadly as being poisoned at twice the rate from two factions. jfid = if store == COrgan && not (IK.isTimerNone tim) || grp == "impressed" then jfidRaw else Nothing (itemKnown, itemFull) = let (kindIx, ar, _) = itemKnownRaw in ( (kindIx, ar, jfid) , itemFullRaw {itemBase = (itemBase itemFullRaw) {jfid}} ) kitNew = case mcount of Just itemK -> (itemK, []) Nothing -> kitRaw itemRev <- getsServer sitemRev let mquant = case HM.lookup itemKnown itemRev of Nothing -> Nothing Just iid -> (iid,) <$> iid `EM.lookup` bagBefore case mquant of Just (iid, (_, afterIt@(timer : rest))) | not $ IK.isTimerNone tim -> do -- Already has such items and timer change requested, so only increase -- the timer of the first item by the delta, but don't create items. let newIt = timer `timeShift` delta : rest if afterIt /= newIt then do execUpdAtomic $ UpdTimeItem iid c afterIt newIt -- It's hard for the client to tell this timer change from charge use, -- timer reset on pickup, etc., so we create the msg manually. execSfxAtomic $ SfxMsgFid (bfid tb) $ SfxTimerExtended (blid tb) target iid store return UseUp else return UseDud -- probably incorrect content, but let it be _ -> do -- No such items or some items, but void delta, so create items. -- If it's, e.g., a periodic poison, the new items will stack with any -- already existing items. iid <- registerItem (itemFull, kitNew) itemKnown c True -- If created not on the ground, ID it, because it won't be on pickup. when (store /= CGround) $ discoverIfMinorEffects c iid (itemKindId itemFull) -- Now, if timer change requested, change the timer, but in the new items, -- possibly increased in number wrt old items. when (not $ IK.isTimerNone tim) $ do tb2 <- getsState $ getActorBody target bagAfter <- getsState $ getBodyStoreBag tb2 store localTime <- getsState $ getLocalTime (blid tb) let newTimer = localTime `timeShift` delta (afterK, afterIt) = fromMaybe (error $ "" `showFailure` (iid, bagAfter, c)) (iid `EM.lookup` bagAfter) newIt = replicate afterK newTimer when (afterIt /= newIt) $ execUpdAtomic $ UpdTimeItem iid c afterIt newIt return UseUp -- ** DropItem -- | Make the target actor drop items in a store from the given group. effectDropItem :: MonadServerAtomic m => m () -> Int -> Int -> CStore -> GroupName ItemKind -> ActorId -> m UseResult effectDropItem execSfx ngroup kcopy store grp target = do b <- getsState $ getActorBody target is <- allGroupItems store grp target if null is then return UseDud else do unless (store == COrgan) execSfx mapM_ (uncurry (dropCStoreItem True store target b kcopy)) $ take ngroup is return UseUp allGroupItems :: MonadServerAtomic m => CStore -> GroupName ItemKind -> ActorId -> m [(ItemId, ItemQuant)] allGroupItems store grp target = do b <- getsState $ getActorBody target getKind <- getsState $ flip getIidKindServer let hasGroup (iid, _) = maybe False (> 0) $ lookup grp $ IK.ifreq $ getKind iid assocsCStore <- getsState $ EM.assocs . getBodyStoreBag b store return $! filter hasGroup assocsCStore -- | 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 :: MonadServerAtomic m => Bool -> CStore -> ActorId -> Actor -> Int -> ItemId -> ItemQuant -> m () dropCStoreItem verbose store aid b kMax iid kit@(k, _) = do itemFull@ItemFull{itemKind} <- getsState $ itemToFull iid let c = CActor aid store fragile = IK.Fragile `elem` IK.ifeature itemKind durable = IK.Durable `elem` IK.ifeature itemKind isDestroyed = bproj b && (bhp b <= 0 && not durable || fragile) || fragile && durable -- hack for tmp organs if isDestroyed then do let effs = IK.strengthOnSmash itemKind -- Activate even if effects null, to destroy the item. effectAndDestroy False aid aid iid c False effs (itemFull, kit) else do cDrop <- pickDroppable aid b mvCmd <- generalMoveItem verbose iid (min kMax k) (CActor aid store) cDrop mapM_ execUpdAtomic mvCmd pickDroppable :: MonadStateRead m => ActorId -> Actor -> m Container pickDroppable aid b = do COps{coTileSpeedup} <- getsState scops lvl <- getLevel (blid b) let validTile t = not $ Tile.isNoItem coTileSpeedup t if validTile $ lvl `at` bpos b then return $! CActor aid CGround else do ps <- getsState $ nearbyFreePoints validTile (bpos b) (blid b) return $! case filter (adjacent $ bpos b) $ take 8 ps of [] -> CActor aid CGround -- fallback; still correct, though not ideal pos : _ -> CFloor (blid b) pos -- ** PolyItem effectPolyItem :: MonadServerAtomic m => m () -> ActorId -> ActorId -> m UseResult effectPolyItem execSfx source target = do sb <- getsState $ getActorBody source let cstore = CGround kitAss <- getsState $ kitAssocs target [cstore] case kitAss of [] -> do execSfxAtomic $ SfxMsgFid (bfid sb) $ SfxPurposeNothing cstore return UseId (iid, ( ItemFull{itemBase, itemKindId, itemKind} , (itemK, itemTimer) )) : _ -> do let maxCount = Dice.maxDice $ IK.icount itemKind if | IK.Unique `elem` IK.ifeature itemKind -> do execSfxAtomic $ SfxMsgFid (bfid sb) SfxPurposeUnique return UseId | maybe True (<= 0) $ lookup "common item" $ IK.ifreq itemKind -> do execSfxAtomic $ SfxMsgFid (bfid sb) SfxPurposeNotCommon return UseId | itemK < maxCount -> do execSfxAtomic $ SfxMsgFid (bfid sb) $ SfxPurposeTooFew maxCount itemK return UseId | otherwise -> do -- Only the required number of items is used up, not all of them. let c = CActor target cstore kit = (maxCount, take maxCount itemTimer) execSfx identifyIid iid c itemKindId execUpdAtomic $ UpdDestroyItem iid itemBase kit c effectCreateItem (Just $ bfid sb) Nothing target cstore "common item" IK.timerNone -- ** Identify effectIdentify :: MonadServerAtomic m => m () -> ItemId -> ActorId -> ActorId -> m UseResult effectIdentify execSfx iidId source target = do COps{coItemSpeedup} <- getsState scops sb <- getsState $ getActorBody source s <- getsServer $ (EM.! bfid sb) . sclientStates let tryFull store as = case as of [] -> return False (iid, _) : rest | iid == iidId -> tryFull store rest -- don't id itself (iid, ItemFull{itemBase, itemKindId, itemKind}) : rest -> do let kindIsKnown = case jkind itemBase of IdentityObvious _ -> True IdentityCovered ix _ -> ix `EM.member` sdiscoKind s if iid `EM.member` sdiscoAspect s -- already fully identified || IK.isHumanTrinket itemKind -- hack; keep them non-identified || store == CGround && IK.onlyMinorEffects itemKind -- will be identified when picked up, so don't bother || IA.kmConst (IK.getKindMean itemKindId coItemSpeedup) && kindIsKnown -- constant aspects and known kind; no need to identify further then tryFull store rest else do let c = CActor target store execSfx identifyIid iid c itemKindId return True tryStore stores = case stores of [] -> do execSfxAtomic $ SfxMsgFid (bfid sb) SfxIdentifyNothing return UseId -- the message tells it's ID effect store : rest -> do allAssocs <- getsState $ fullAssocs target [store] go <- tryFull store allAssocs if go then return UseUp else tryStore rest tryStore [CGround, CEqp, CInv, CSha] identifyIid :: MonadServerAtomic m => ItemId -> Container -> ContentId ItemKind -> m () identifyIid iid c itemKindId = do discoAspect <- getsState sdiscoAspect execUpdAtomic $ UpdDiscover c iid itemKindId $ discoAspect EM.! iid -- ** Detect effectDetect :: MonadServerAtomic m => m () -> IK.DetectKind -> Int -> ActorId -> Point -> m UseResult effectDetect execSfx d radius target pos = do COps{coTileSpeedup} <- getsState scops b <- getsState $ getActorBody target lvl <- getLevel $ blid b let (predicate, action) = case d of IK.DetectAll -> (const True, const $ return False) IK.DetectActor -> ((`EM.member` lactor lvl), const $ return False) IK.DetectItem -> ((`EM.member` lfloor lvl), const $ return False) IK.DetectExit -> let (ls1, ls2) = lstair lvl in ((`elem` ls1 ++ ls2 ++ lescape lvl), const $ return False) IK.DetectHidden -> let predicateH p = Tile.isHideAs coTileSpeedup $ lvl `at` p revealEmbed p = do embeds <- getsState $ getEmbedBag (blid b) p unless (EM.null embeds) $ do s <- getState let ais = map (\iid -> (iid, getItemBody iid s)) (EM.keys embeds) execUpdAtomic $ UpdSpotItemBag (CEmbed (blid b) p) embeds ais actionH l = do let f p = when (p /= pos) $ do let t = lvl `at` p execUpdAtomic $ UpdSearchTile target p t -- This is safe searching; embedded items -- are not triggered, but they are revealed. revealEmbed p mapM_ f l return $! not $ null l in (predicateH, actionH) IK.DetectEmbed -> ((`EM.member` lembed lvl), const $ return False) effectDetectX d predicate action execSfx radius target effectDetectX :: MonadServerAtomic m => IK.DetectKind -> (Point -> Bool) -> ([Point] -> m Bool) -> m () -> Int -> ActorId -> m UseResult effectDetectX d predicate action execSfx radius target = do b <- getsState $ getActorBody target Level{lxsize, lysize} <- getLevel $ blid b sperFidOld <- getsServer sperFid let perOld = sperFidOld EM.! bfid b EM.! blid b Point x0 y0 = bpos b perList = filter predicate [ Point x y | y <- [max 0 (y0 - radius) .. min (lysize - 1) (y0 + radius)] , x <- [max 0 (x0 - radius) .. min (lxsize - 1) (x0 + radius)] ] extraPer = emptyPer {psight = PerVisible $ ES.fromDistinctAscList perList} inPer = diffPer extraPer perOld unless (nullPer inPer) $ do -- Perception is modified on the server and sent to the client -- together with all the revealed info. let perNew = addPer inPer perOld fper = EM.adjust (EM.insert (blid b) perNew) (bfid b) modifyServer $ \ser -> ser {sperFid = fper $ sperFid ser} execSendPer (bfid b) (blid b) emptyPer inPer perNew pointsModified <- action perList if not (nullPer inPer) || pointsModified then do execSfx -- Perception is reverted. This is necessary to ensure save and restore -- doesn't change game state. unless (nullPer inPer) $ do modifyServer $ \ser -> ser {sperFid = sperFidOld} execSendPer (bfid b) (blid b) inPer emptyPer perOld else execSfxAtomic $ SfxMsgFid (bfid b) $ SfxVoidDetection d return UseUp -- even if nothing spotted, in itself it's still useful data -- ** SendFlying -- | Send the target actor flying like a projectile. 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 :: MonadServerAtomic m => m () -> IK.ThrowMod -> ActorId -> ActorId -> Maybe Bool -> m UseResult effectSendFlying execSfx IK.ThrowMod{..} source target modePush = do v <- sendFlyingVector source target modePush tb <- getsState $ getActorBody target Level{lxsize, lysize} <- getLevel (blid tb) let eps = 0 fpos = bpos tb `shift` v if braced tb then do sb <- getsState $ getActorBody source execSfxAtomic $ SfxMsgFid (bfid sb) $ SfxBracedImmune target return UseId -- the message reveals what's going on else case bla lxsize lysize eps (bpos tb) fpos of Nothing -> error $ "" `showFailure` (fpos, tb) Just [] -> error $ "projecting from the edge of level" `showFailure` (fpos, tb) Just (pos : rest) -> do weightAssocs <- getsState $ fullAssocs target [CInv, CEqp, COrgan] let weight = sum $ map (IK.iweight . itemKind . snd) weightAssocs path = bpos tb : pos : rest (trajectory, (speed, range)) = computeTrajectory weight throwVelocity throwLinger path ts = Just (trajectory, speed) if null trajectory || btrajectory tb == ts then return UseId -- e.g., actor is too heavy; but a jerk is noticeable else do execSfx execUpdAtomic $ UpdTrajectory target (btrajectory tb) ts -- Give the actor back all the time spent flying (range/speed) -- and also let the push start ASAP. So, he will not lose -- any turn of movement (but he may need to retrace the push). let delta = timeDeltaScale (ticksPerMeter speed) (-range) modifyServer $ \ser -> ser {sactorTime = ageActor (bfid tb) (blid tb) target delta $ sactorTime ser} return UseUp sendFlyingVector :: MonadServerAtomic m => ActorId -> ActorId -> Maybe Bool -> m Vector sendFlyingVector source target modePush = do sb <- getsState $ getActorBody source let boldpos_sb = fromMaybe (bpos sb) (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 pushV = vectorToFrom (bpos tb) (bpos sb) pullV = vectorToFrom (bpos sb) (bpos tb) return $! case modePush of Just True -> pushV Just False -> pullV Nothing | adjacent (bpos sb) (bpos tb) -> pushV Nothing -> pullV -- ** DropBestWeapon -- | Make the target actor drop his best weapon (stack). effectDropBestWeapon :: MonadServerAtomic m => m () -> ActorId -> m UseResult effectDropBestWeapon execSfx target = do tb <- getsState $ getActorBody target localTime <- getsState $ getLocalTime (blid tb) kitAssRaw <- getsState $ kitAssocs target [CEqp] let kitAss = filter (IK.isMelee . itemKind . fst . snd) kitAssRaw case strongestMelee Nothing localTime kitAss of (_, (iid, _)) : _ -> do execSfx let kit = beqp tb EM.! iid dropCStoreItem True CEqp target tb 1 iid kit -- not the whole stack return UseUp [] -> return UseDud -- ** 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 :: MonadServerAtomic m => m () -> ActorId -> Char -> m UseResult effectActivateInv execSfx target symbol = do let c = CActor target CInv effectTransformContainer execSfx symbol c $ \iid _ -> meleeEffectAndDestroy target target iid c effectTransformContainer :: forall m. MonadServerAtomic m => m () -> Char -> Container -> (ItemId -> ItemQuant -> m ()) -> m UseResult effectTransformContainer execSfx symbol c m = do getKind <- getsState $ flip getIidKindServer let hasSymbol (iid, _kit) = do let jsymbol = IK.isymbol $ getKind iid return $! jsymbol == symbol assocsCStore <- getsState $ EM.assocs . getContainerBag c is <- if symbol == ' ' then return assocsCStore else filterM hasSymbol assocsCStore if null is then return UseDud else do execSfx mapM_ (uncurry m) is -- Even if no item produced any visible effect, rummaging through -- the inventory uses up the effect and produced discernible vibrations. return UseUp -- ** ApplyPerfume effectApplyPerfume :: MonadServerAtomic m => m () -> ActorId -> m UseResult effectApplyPerfume execSfx target = do tb <- getsState $ getActorBody target Level{lsmell} <- getLevel $ blid tb unless (EM.null lsmell) $ do execSfx let f p fromSm = execUpdAtomic $ UpdAlterSmell (blid tb) p fromSm timeZero mapWithKeyM_ f lsmell return UseUp -- even if no smell before, the perfume is noticeable -- ** OneOf effectOneOf :: MonadServerAtomic m => (IK.Effect -> m UseResult) -> [IK.Effect] -> m UseResult effectOneOf recursiveCall l = do let call1 = do ef <- rndToAction $ oneOf l recursiveCall ef call99 = replicate 99 call1 f call result = do ur <- call -- We avoid 99 calls to a fizzling effect that only prints -- a failure message and IDs the item. if ur == UseDud then result else return ur foldr f (return UseDud) call99 -- no @execSfx@, because individual effects sent them -- ** Recharging effectRecharging :: MonadServerAtomic m => (IK.Effect -> m UseResult) -> IK.Effect -> Bool -> m UseResult effectRecharging recursiveCall e recharged = if recharged then recursiveCall e else return UseDud -- ** Temporary effectTemporary :: MonadServerAtomic m => m () -> ActorId -> ItemId -> Container -> m UseResult effectTemporary execSfx source iid c = do case c of CActor _ COrgan -> do b <- getsState $ getActorBody source case iid `EM.lookup` borgan b of Just _ -> return () -- still some copies left of a multi-copy tmp organ Nothing -> execSfx -- last copy just destroyed _ -> execSfx return UseUp -- temporary, so usually used up just by sitting there -- ** Composite effectComposite :: forall m. MonadServerAtomic m => (IK.Effect -> m UseResult) -> [IK.Effect] -> m UseResult effectComposite recursiveCall l = do let f :: IK.Effect -> m UseResult -> m UseResult f eff result = do ur <- recursiveCall eff when (ur == UseUp) $ void result -- UseResult comes from the first return ur foldr f (return UseDud) l -- no @execSfx@, because individual effects sent them LambdaHack-0.8.3.0/Game/LambdaHack/Server/MonadServer.hs0000644000000000000000000002037513315545734020705 0ustar0000000000000000-- | Basic server monads and related operations. module Game.LambdaHack.Server.MonadServer ( -- * The server monad MonadServer( getsServer , modifyServer , chanSaveServer -- exposed only to be implemented, not used , liftIO -- exposed only to be implemented, not used ) , MonadServerAtomic(..) -- * Assorted primitives , getServer, putServer, debugPossiblyPrint, debugPossiblyPrintAndExit , serverPrint, saveServer, dumpRngs, restoreScore, registerScore , rndToAction, getSetGen ) where import Prelude () import Game.LambdaHack.Common.Prelude -- Cabal import qualified Paths_LambdaHack as Self (version) import qualified Control.Exception as Ex import qualified Control.Monad.Trans.State.Strict as St import qualified Data.EnumMap.Strict as EM import qualified Data.Text as T import qualified Data.Text.IO as T import Data.Time.Clock.POSIX import Data.Time.LocalTime import System.Exit (exitFailure) import System.FilePath import System.IO (hFlush, stdout) import qualified System.Random as R import Game.LambdaHack.Atomic import Game.LambdaHack.Client (sbenchmark) import Game.LambdaHack.Common.ActorState import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.File import qualified Game.LambdaHack.Common.HighScore as HighScore import Game.LambdaHack.Common.Kind import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.MonadStateRead import Game.LambdaHack.Common.Perception import Game.LambdaHack.Common.Random import qualified Game.LambdaHack.Common.Save as Save import Game.LambdaHack.Common.State import Game.LambdaHack.Content.ModeKind import Game.LambdaHack.Content.RuleKind import Game.LambdaHack.Server.ServerOptions import Game.LambdaHack.Server.State class MonadStateRead m => MonadServer m where getsServer :: (StateServer -> a) -> m a modifyServer :: (StateServer -> StateServer) -> m () chanSaveServer :: m (Save.ChanSave (State, StateServer)) -- We do not provide a MonadIO instance, so that outside -- nobody can subvert the action monads by invoking arbitrary IO. liftIO :: IO a -> m a -- | The monad for executing atomic game state transformations. class MonadServer m => MonadServerAtomic m where -- | Execute an atomic command that changes the state -- on the server and on all clients that can notice it. execUpdAtomic :: UpdAtomic -> m () -- | Execute an atomic command that changes the state -- on the server only. execUpdAtomicSer :: UpdAtomic -> m Bool -- | Execute an atomic command that changes the state -- on the given single client only. execUpdAtomicFid :: FactionId -> UpdAtomic -> m () -- | Execute an atomic command that changes the state -- on the given single client only. -- Catch 'AtomicFail' and indicate if it was in fact raised. execUpdAtomicFidCatch :: FactionId -> UpdAtomic -> m Bool -- | Execute an atomic command that only displays special effects. execSfxAtomic :: SfxAtomic -> m () execSendPer :: FactionId -> LevelId -> Perception -> Perception -> Perception -> m () getServer :: MonadServer m => m StateServer getServer = getsServer id putServer :: MonadServer m => StateServer -> m () putServer s = modifyServer (const s) debugPossiblyPrint :: MonadServer m => Text -> m () debugPossiblyPrint t = do debug <- getsServer $ sdbgMsgSer . soptions when debug $ liftIO $ do T.hPutStrLn stdout t hFlush stdout debugPossiblyPrintAndExit :: MonadServer m => Text -> m () debugPossiblyPrintAndExit t = do debug <- getsServer $ sdbgMsgSer . soptions when debug $ liftIO $ do T.hPutStrLn stdout t hFlush stdout exitFailure serverPrint :: MonadServer m => Text -> m () serverPrint t = liftIO $ do T.hPutStrLn stdout t hFlush stdout saveServer :: MonadServer m => m () saveServer = do s <- getState ser <- getServer toSave <- chanSaveServer liftIO $ Save.saveToChan toSave (s, ser) -- | Dumps to stdout the RNG states from the start of the game. dumpRngs :: MonadServer m => RNGs -> m () dumpRngs rngs = liftIO $ do T.hPutStrLn stdout $ tshow rngs hFlush stdout -- | Read the high scores dictionary. Return the empty table if no file. restoreScore :: forall m. MonadServer m => COps -> m HighScore.ScoreDict restoreScore cops = do bench <- getsServer $ sbenchmark . sclientOptions . soptions mscore <- if bench then return Nothing else do let stdRuleset = getStdRuleset cops scoresFile = rscoresFile stdRuleset dataDir <- liftIO appDataDir let path bkp = dataDir bkp <> scoresFile configExists <- liftIO $ doesFileExist (path "") res <- liftIO $ Ex.try $ if configExists then do (vlib2, s) <- strictDecodeEOF (path "") if vlib2 == Self.version then return $ Just s else do let msg = "High score file from old version of game detected." fail msg else return Nothing let handler :: Ex.SomeException -> m (Maybe a) handler e = do let msg = "High score restore failed. The old file moved aside. The error message is:" <+> (T.unwords . T.lines) (tshow e) serverPrint msg liftIO $ renameFile (path "") (path "bkp.") return Nothing either handler return res maybe (return HighScore.empty) return mscore -- | Generate a new score, register it and save. registerScore :: MonadServer m => Status -> FactionId -> m () registerScore status fid = do cops <- getsState scops total <- getsState $ snd . calculateTotal fid let stdRuleset = getStdRuleset cops 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 dungeonTotal <- getsState sgold date <- liftIO getPOSIXTime tz <- liftIO $ getTimeZone $ posixSecondsToUTCTime date curChalSer <- getsServer $ scurChalSer . soptions factionD <- getsState sfactionD bench <- getsServer $ sbenchmark . sclientOptions . soptions noConfirmsGame <- isNoConfirmsGame let fact = factionD EM.! fid path = dataDir scoresFile outputScore (worthMentioning, (ntable, pos)) = -- If testing or fooling around, dump instead of registering. -- In particular don't register score for the auto-* scenarios. if bench || noConfirmsGame || isAIFact fact then debugPossiblyPrint $ T.intercalate "\n" $ HighScore.showScore tz (pos, HighScore.getRecord pos ntable) else let nScoreDict = EM.insert gameModeId ntable scoreDict in when worthMentioning $ liftIO $ encodeEOF path (Self.version, nScoreDict :: HighScore.ScoreDict) chal | fhasUI $ gplayer fact = curChalSer | otherwise = curChalSer {cdiff = difficultyInverse (cdiff curChalSer)} theirVic (fi, fa) | isFoe fid fact fi && not (isHorrorFact fa) = Just $ gvictims fa | otherwise = Nothing theirVictims = EM.unionsWith (+) $ mapMaybe theirVic $ EM.assocs factionD ourVic (fi, fa) | isFriend fid fact fi = Just $ gvictims fa | otherwise = Nothing ourVictims = EM.unionsWith (+) $ mapMaybe ourVic $ EM.assocs factionD table = HighScore.getTable gameModeId scoreDict registeredScore = HighScore.register table total dungeonTotal time status date chal (T.unwords $ tail $ T.words $ gname fact) ourVictims theirVictims (fhiCondPoly $ gplayer fact) outputScore registeredScore -- | Invoke pseudo-random computation with the generator kept in the state. rndToAction :: MonadServer m => Rnd a -> m a rndToAction r = do gen1 <- getsServer srandom let (a, gen2) = St.runState r gen1 modifyServer $ \ser -> ser {srandom = gen2} return a -- | Gets a random generator from the user-submitted options or, if not present, -- generates one. getSetGen :: MonadServer m => Maybe R.StdGen -> m R.StdGen getSetGen mrng = case mrng of Just rnd -> return rnd Nothing -> liftIO R.newStdGen LambdaHack-0.8.3.0/Game/LambdaHack/Server/EndM.hs0000644000000000000000000001475213315545734017305 0ustar0000000000000000-- | Server operations used when ending game and deciding whether to end. module Game.LambdaHack.Server.EndM ( endOrLoop, dieSer, writeSaveAll #ifdef EXPOSE_INTERNAL -- * Internal operations , gameExit, dropAllItems #endif ) where import Prelude () import Game.LambdaHack.Common.Prelude import qualified Data.EnumMap.Strict as EM import Game.LambdaHack.Atomic import Game.LambdaHack.Client (sbenchmark) import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.MonadStateRead import Game.LambdaHack.Common.State import Game.LambdaHack.Content.ModeKind import Game.LambdaHack.Server.CommonM import Game.LambdaHack.Server.Fov import Game.LambdaHack.Server.HandleEffectM import Game.LambdaHack.Server.ItemM import Game.LambdaHack.Server.MonadServer import Game.LambdaHack.Server.ProtocolM import Game.LambdaHack.Server.ServerOptions import Game.LambdaHack.Server.State -- | Continue or exit or restart the game. endOrLoop :: (MonadServerAtomic m, MonadServerComm m) => m () -> (Maybe (GroupName ModeKind) -> m ()) -> m () endOrLoop loop restart = do factionD <- getsState sfactionD let inGame fact = case gquit fact of Nothing -> True Just Status{stOutcome=Camping} -> True _ -> False gameOver = not $ any inGame $ EM.elems factionD let getQuitter fact = case gquit fact of Just Status{stOutcome=Restart, stNewGame} -> stNewGame _ -> Nothing quitters = mapMaybe getQuitter $ EM.elems factionD restartNeeded = gameOver || not (null quitters) let isCamper fact = case gquit fact of Just Status{stOutcome=Camping} -> True _ -> False campers = filter (isCamper . snd) $ EM.assocs factionD -- Wipe out the quit flag for the savegame files. mapM_ (\(fid, fact) -> execUpdAtomic $ UpdQuitFaction fid (gquit fact) Nothing) campers swriteSave <- getsServer swriteSave when swriteSave $ do modifyServer $ \ser -> ser {swriteSave = False} writeSaveAll True if | restartNeeded -> restart (listToMaybe quitters) | not $ null campers -> gameExit -- and @loop@ is not called | otherwise -> loop -- continue current game gameExit :: (MonadServerAtomic m, MonadServerComm m) => m () gameExit = do -- debugPossiblyPrint "Verifying all perceptions." -- Verify that the possibly not saved caches are equal to future -- reconstructed. Otherwise, save/restore would change game state. -- This is done even in released binaries, because it only prolongs -- game shutdown a bit. The same checks at each periodic game save -- would icrease the game saving lag, so they are normally avoided. verifyCaches -- Kill all clients, including those that did not take part -- in the current game. -- Clients exit not now, but after they print all ending screens. -- debugPrint "Server kills clients" -- debugPossiblyPrint "Killing all clients." killAllClients -- debugPossiblyPrint "All clients killed." return () verifyCaches :: MonadServer m => m () verifyCaches = do sperCacheFid <- getsServer sperCacheFid sperValidFid <- getsServer sperValidFid sactorAspect2 <- getsState sactorAspect sfovLucidLid <- getsServer sfovLucidLid sfovClearLid <- getsServer sfovClearLid sfovLitLid <- getsServer sfovLitLid sperFid <- getsServer sperFid actorAspect <- getsState actorAspectInDungeon ( fovLitLid, fovClearLid, fovLucidLid ,perValidFid, perCacheFid, perFid ) <- getsState perFidInDungeon let !_A7 = assert (sfovLitLid == fovLitLid `blame` "wrong accumulated sfovLitLid" `swith` (sfovLitLid, fovLitLid)) () !_A6 = assert (sfovClearLid == fovClearLid `blame` "wrong accumulated sfovClearLid" `swith` (sfovClearLid, fovClearLid)) () !_A5 = assert (sactorAspect2 == actorAspect `blame` "wrong accumulated sactorAspect" `swith` (sactorAspect2, actorAspect)) () !_A4 = assert (sfovLucidLid == fovLucidLid `blame` "wrong accumulated sfovLucidLid" `swith` (sfovLucidLid, fovLucidLid)) () !_A3 = assert (sperValidFid == perValidFid `blame` "wrong accumulated sperValidFid" `swith` (sperValidFid, perValidFid)) () !_A2 = assert (sperCacheFid == perCacheFid `blame` "wrong accumulated sperCacheFid" `swith` (sperCacheFid, perCacheFid)) () !_A1 = assert (sperFid == perFid `blame` "wrong accumulated perception" `swith` (sperFid, perFid)) () return () dieSer :: MonadServerAtomic m => ActorId -> Actor -> m () dieSer aid b = do b2 <- if bproj b then return b else do kindId <- getsState $ getIidKindIdServer $ btrunk b execUpdAtomic $ UpdRecordKill aid kindId 1 -- At this point the actor's body exists and his items are not dropped. deduceKilled aid electLeader (bfid b) (blid b) aid 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 False aid CSha CInv getsState $ getActorBody aid -- If the actor was a projectile and no effect was triggered by hitting -- an enemy, the item still exists and @OnSmash@ effects will be triggered: dropAllItems aid b2 b3 <- getsState $ getActorBody aid execUpdAtomic $ UpdDestroyActor aid b3 [] -- | Drop all actor's items. dropAllItems :: MonadServerAtomic m => ActorId -> Actor -> m () dropAllItems aid b = do mapActorCStore_ CInv (dropCStoreItem False CInv aid b maxBound) b mapActorCStore_ CEqp (dropCStoreItem False CEqp aid b maxBound) b -- | Save game on server and all clients. writeSaveAll :: MonadServerAtomic m => Bool -> m () writeSaveAll uiRequested = do bench <- getsServer $ sbenchmark . sclientOptions . soptions noConfirmsGame <- isNoConfirmsGame when (uiRequested || not bench && not noConfirmsGame) $ do execUpdAtomic UpdWriteSave saveServer #ifdef WITH_EXPENSIVE_ASSERTIONS -- This check is sometimes repeated in @gameExit@, but we don't care about -- speed of shutdown and even more so in WITH_EXPENSIVE_ASSERTIONS mode. verifyCaches #endif LambdaHack-0.8.3.0/Game/LambdaHack/Server/State.hs0000644000000000000000000001276313315545734017542 0ustar0000000000000000-- | Server and client game state types and operations. module Game.LambdaHack.Server.State ( StateServer(..), ActorTime , emptyStateServer, updateActorTime, ageActor ) where import Prelude () import Game.LambdaHack.Common.Prelude import Data.Binary import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES import qualified Data.HashMap.Strict as HM import qualified System.Random as R import Game.LambdaHack.Atomic import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.Item import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Perception import Game.LambdaHack.Common.State import Game.LambdaHack.Common.Time import Game.LambdaHack.Server.Fov import Game.LambdaHack.Server.ItemRev import Game.LambdaHack.Server.ServerOptions -- | State with server-specific data, including a copy of each client's -- basic game state, but not the server's basic state. data StateServer = StateServer { sactorTime :: ActorTime -- ^ absolute times of next actions , sactorStasis :: ES.EnumSet ActorId -- ^ actors currently in time stasis, -- invulnerable to time warps until move , sdiscoKindRev :: DiscoveryKindRev -- ^ reverse map, used for item creation , suniqueSet :: UniqueSet -- ^ already generated unique items , sitemRev :: ItemRev -- ^ reverse id map, used for item creation , sflavour :: FlavourMap -- ^ association of flavour to items , sacounter :: ActorId -- ^ stores next actor index , sicounter :: ItemId -- ^ stores next item index , snumSpawned :: EM.EnumMap LevelId Int , sundo :: [CmdAtomic] -- ^ atomic commands performed to date , sclientStates :: EM.EnumMap FactionId State -- ^ each faction state, as seen by clients , sperFid :: PerFid -- ^ perception of all factions , sperValidFid :: PerValidFid -- ^ perception validity for all factions , sperCacheFid :: PerCacheFid -- ^ perception cache of all factions , sfovLucidLid :: FovLucidLid -- ^ ambient or shining light positions , sfovClearLid :: FovClearLid -- ^ clear tiles positions , sfovLitLid :: FovLitLid -- ^ ambient light positions , sarenas :: [LevelId] -- ^ active arenas , svalidArenas :: Bool -- ^ whether active arenas valid , srandom :: R.StdGen -- ^ current random generator , srngs :: RNGs -- ^ initial random generators , sbreakLoop :: Bool -- ^ exit game loop after clip's end; -- usually no game save follows , sbreakASAP :: Bool -- ^ exit game loop ASAP; usually with save , swriteSave :: Bool -- ^ write savegame to file after loop exit , soptions :: ServerOptions -- ^ current commandline options , soptionsNxt :: ServerOptions -- ^ options for the next game } deriving Show -- | Position in time for each actor, grouped by level and by faction. type ActorTime = EM.EnumMap FactionId (EM.EnumMap LevelId (EM.EnumMap ActorId Time)) -- | Initial, empty game server state. emptyStateServer :: StateServer emptyStateServer = StateServer { sactorTime = EM.empty , sactorStasis = ES.empty , sdiscoKindRev = emptyDiscoveryKindRev , suniqueSet = ES.empty , sitemRev = HM.empty , sflavour = emptyFlavourMap , sacounter = toEnum 0 , sicounter = toEnum 0 , snumSpawned = EM.empty , sundo = [] , sclientStates = EM.empty , sperFid = EM.empty , sperValidFid = EM.empty , sperCacheFid = EM.empty , sfovLucidLid = EM.empty , sfovClearLid = EM.empty , sfovLitLid = EM.empty , sarenas = [] , svalidArenas = False , srandom = R.mkStdGen 42 , srngs = RNGs { dungeonRandomGenerator = Nothing , startingRandomGenerator = Nothing } , sbreakLoop = False , sbreakASAP = False , swriteSave = False , soptions = defServerOptions , soptionsNxt = defServerOptions } updateActorTime :: FactionId -> LevelId -> ActorId -> Time -> ActorTime -> ActorTime updateActorTime !fid !lid !aid !time = EM.adjust (EM.adjust (EM.insert aid time) lid) fid ageActor :: FactionId -> LevelId -> ActorId -> Delta Time -> ActorTime -> ActorTime ageActor !fid !lid !aid !delta = EM.adjust (EM.adjust (EM.adjust (`timeShift` delta) aid) lid) fid instance Binary StateServer where put StateServer{..} = do put sactorTime put sactorStasis put sdiscoKindRev put suniqueSet put sitemRev put sflavour put sacounter put sicounter put snumSpawned put sclientStates put (show srandom) put srngs put soptions get = do sactorTime <- get sactorStasis <- get sdiscoKindRev <- get suniqueSet <- get sitemRev <- get sflavour <- get sacounter <- get sicounter <- get snumSpawned <- get sclientStates <- get g <- get srngs <- get soptions <- get let srandom = read g sundo = [] sperFid = EM.empty sperValidFid = EM.empty sperCacheFid = EM.empty sfovLucidLid = EM.empty sfovClearLid = EM.empty sfovLitLid = EM.empty sarenas = [] svalidArenas = False sbreakLoop = False sbreakASAP = False swriteSave = False soptionsNxt = defServerOptions return $! StateServer{..} LambdaHack-0.8.3.0/Game/LambdaHack/Server/HandleAtomicM.hs0000644000000000000000000003154413315545734021125 0ustar0000000000000000-- | Handle atomic commands on the server, after they are executed -- to change server 'State' and before they are sent to clients. module Game.LambdaHack.Server.HandleAtomicM ( cmdAtomicSemSer #ifdef EXPOSE_INTERNAL -- * Internal operations , invalidateArenas, updateSclear, updateSlit , invalidateLucidLid, invalidateLucidAid , actorHasShine, itemAffectsShineRadius, itemAffectsPerRadius , addPerActor, addPerActorAny, deletePerActor, deletePerActorAny , invalidatePerActor, reconsiderPerActor, invalidatePerLid #endif ) where import Prelude () import Game.LambdaHack.Common.Prelude import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES import Game.LambdaHack.Atomic import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState import Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.ItemAspect as IA import Game.LambdaHack.Common.Kind import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.MonadStateRead import Game.LambdaHack.Common.Point import qualified Game.LambdaHack.Common.PointArray as PointArray import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile import Game.LambdaHack.Content.TileKind (TileKind) import Game.LambdaHack.Server.Fov import Game.LambdaHack.Server.MonadServer import Game.LambdaHack.Server.State -- | Effect of atomic actions on server state is calculated -- with the global state from after the command is executed -- (except where the supplied @oldState@ is used). cmdAtomicSemSer :: MonadServer m => State -> UpdAtomic -> m () cmdAtomicSemSer oldState cmd = case cmd of UpdCreateActor aid b _ -> do actorAspect <- getsState sactorAspect when (actorHasShine actorAspect aid) $ invalidateLucidLid $ blid b addPerActor aid b UpdDestroyActor aid b _ -> do let actorAspectOld = sactorAspect oldState when (actorHasShine actorAspectOld aid) $ invalidateLucidLid $ blid b deletePerActor actorAspectOld aid b modifyServer $ \ser -> ser { sactorTime = EM.adjust (EM.adjust (EM.delete aid) (blid b)) (bfid b) (sactorTime ser) , sactorStasis = ES.delete aid (sactorStasis ser) } UpdCreateItem iid _ _ (CFloor lid _) -> do discoAspect <- getsState sdiscoAspect when (itemAffectsShineRadius discoAspect iid []) $ invalidateLucidLid lid UpdCreateItem iid _ _ (CActor aid store) -> do discoAspect <- getsState sdiscoAspect when (itemAffectsShineRadius discoAspect iid [store]) $ invalidateLucidAid aid when (store `elem` [CEqp, COrgan]) $ when (itemAffectsPerRadius discoAspect iid) $ reconsiderPerActor aid UpdDestroyItem iid _ _ (CFloor lid _) -> do discoAspect <- getsState sdiscoAspect when (itemAffectsShineRadius discoAspect iid []) $ invalidateLucidLid lid UpdDestroyItem iid _ _ (CActor aid store) -> do discoAspect <- getsState sdiscoAspect when (itemAffectsShineRadius discoAspect iid [store]) $ invalidateLucidAid aid when (store `elem` [CEqp, COrgan]) $ when (itemAffectsPerRadius discoAspect iid) $ reconsiderPerActor aid UpdSpotActor aid b _ -> do -- On server, it does't affect aspects, but does affect lucid (Ascend). actorAspect <- getsState sactorAspect when (actorHasShine actorAspect aid) $ invalidateLucidLid $ blid b addPerActor aid b UpdLoseActor aid b _ -> do -- On server, it does't affect aspects, but does affect lucid (Ascend). let actorAspectOld = sactorAspect oldState when (actorHasShine actorAspectOld aid) $ invalidateLucidLid $ blid b deletePerActor actorAspectOld aid b modifyServer $ \ser -> ser { sactorTime = EM.adjust (EM.adjust (EM.delete aid) (blid b)) (bfid b) (sactorTime ser) , sactorStasis = ES.delete aid (sactorStasis ser) } UpdSpotItem _ iid _ _ (CFloor lid _) -> do discoAspect <- getsState sdiscoAspect when (itemAffectsShineRadius discoAspect iid []) $ invalidateLucidLid lid UpdSpotItem _ iid _ _ (CActor aid store) -> do discoAspect <- getsState sdiscoAspect when (itemAffectsShineRadius discoAspect iid [store]) $ invalidateLucidAid aid when (store `elem` [CEqp, COrgan]) $ when (itemAffectsPerRadius discoAspect iid) $ reconsiderPerActor aid UpdLoseItem _ iid _ _ (CFloor lid _) -> do discoAspect <- getsState sdiscoAspect when (itemAffectsShineRadius discoAspect iid []) $ invalidateLucidLid lid UpdLoseItem _ iid _ _ (CActor aid store) -> do discoAspect <- getsState sdiscoAspect when (itemAffectsShineRadius discoAspect iid [store]) $ invalidateLucidAid aid when (store `elem` [CEqp, COrgan]) $ when (itemAffectsPerRadius discoAspect iid) $ reconsiderPerActor aid UpdSpotItemBag (CFloor lid _) bag _ais -> do discoAspect <- getsState sdiscoAspect let iids = EM.keys bag when (any (\iid -> itemAffectsShineRadius discoAspect iid []) iids) $ invalidateLucidLid lid UpdSpotItemBag (CActor aid store) bag _ais -> do discoAspect <- getsState sdiscoAspect let iids = EM.keys bag when (any (\iid -> itemAffectsShineRadius discoAspect iid [store]) iids) $ invalidateLucidAid aid when (store `elem` [CEqp, COrgan]) $ when (any (itemAffectsPerRadius discoAspect) iids) $ reconsiderPerActor aid UpdLoseItemBag (CFloor lid _) bag _ais -> do discoAspect <- getsState sdiscoAspect let iids = EM.keys bag when (any (\iid -> itemAffectsShineRadius discoAspect iid []) iids) $ invalidateLucidLid lid UpdLoseItemBag (CActor aid store) bag _ais -> do discoAspect <- getsState sdiscoAspect let iids = EM.keys bag when (any (\iid -> itemAffectsShineRadius discoAspect iid [store]) iids) $ invalidateLucidAid aid when (store `elem` [CEqp, COrgan]) $ when (any (itemAffectsPerRadius discoAspect) iids) $ reconsiderPerActor aid UpdMoveActor aid _ _ -> do actorAspect <- getsState sactorAspect when (actorHasShine actorAspect aid) $ invalidateLucidAid aid invalidatePerActor aid UpdDisplaceActor aid1 aid2 -> do actorAspect <- getsState sactorAspect when (actorHasShine actorAspect aid1 || actorHasShine actorAspect aid2) $ invalidateLucidAid aid1 -- the same lid as aid2 invalidatePerActor aid1 invalidatePerActor aid2 UpdMoveItem iid _k aid s1 s2 -> do discoAspect <- getsState sdiscoAspect let itemAffectsPer = itemAffectsPerRadius discoAspect iid invalidatePer = when itemAffectsPer $ reconsiderPerActor aid itemAffectsShine = itemAffectsShineRadius discoAspect iid [s1, s2] invalidateLucid = when itemAffectsShine $ invalidateLucidAid aid case s1 of CEqp -> case s2 of COrgan -> return () _ -> do invalidateLucid invalidatePer COrgan -> case s2 of CEqp -> return () _ -> do invalidateLucid invalidatePer _ -> do invalidateLucid -- from itemAffects, s2 provides light or s1 is CGround when (s2 `elem` [CEqp, COrgan]) invalidatePer UpdRefillCalm aid _ -> do IA.AspectRecord{aSight} <- getsState $ getActorAspect aid body <- getsState $ getActorBody aid let oldBody = getActorBody aid oldState radiusOld = boundSightByCalm aSight (bcalm oldBody) radiusNew = boundSightByCalm aSight (bcalm body) when (radiusOld /= radiusNew) $ invalidatePerActor aid UpdLeadFaction{} -> invalidateArenas UpdRecordKill{} -> invalidateArenas UpdAlterTile lid pos fromTile toTile -> do clearChanged <- updateSclear lid pos fromTile toTile litChanged <- updateSlit lid pos fromTile toTile when (clearChanged || litChanged) $ invalidateLucidLid lid when clearChanged $ invalidatePerLid lid _ -> return () invalidateArenas :: MonadServer m => m () invalidateArenas = modifyServer $ \ser -> ser {svalidArenas = False} updateSclear :: MonadServer m => LevelId -> Point -> ContentId TileKind -> ContentId TileKind -> m Bool updateSclear lid pos fromTile toTile = do COps{coTileSpeedup} <- getsState scops let fromClear = Tile.isClear coTileSpeedup fromTile toClear = Tile.isClear coTileSpeedup toTile if fromClear == toClear then return False else do let f FovClear{fovClear} = FovClear $ fovClear PointArray.// [(pos, toClear)] modifyServer $ \ser -> ser {sfovClearLid = EM.adjust f lid $ sfovClearLid ser} return True updateSlit :: MonadServer m => LevelId -> Point -> ContentId TileKind -> ContentId TileKind -> m Bool updateSlit lid pos fromTile toTile = do COps{coTileSpeedup} <- getsState scops let fromLit = Tile.isLit coTileSpeedup fromTile toLit = Tile.isLit coTileSpeedup toTile if fromLit == toLit then return False else do let f (FovLit set) = FovLit $ if toLit then ES.insert pos set else ES.delete pos set modifyServer $ \ser -> ser {sfovLitLid = EM.adjust f lid $ sfovLitLid ser} return True invalidateLucidLid :: MonadServer m => LevelId -> m () invalidateLucidLid lid = modifyServer $ \ser -> ser { sfovLucidLid = EM.insert lid FovInvalid $ sfovLucidLid ser , sperValidFid = EM.map (EM.insert lid False) $ sperValidFid ser } invalidateLucidAid :: MonadServer m => ActorId -> m () invalidateLucidAid aid = do lid <- getsState $ blid . getActorBody aid invalidateLucidLid lid actorHasShine :: ActorAspect -> ActorId -> Bool actorHasShine actorAspect aid = case EM.lookup aid actorAspect of Just IA.AspectRecord{aShine} -> aShine > 0 Nothing -> error $ "" `showFailure` aid itemAffectsShineRadius :: DiscoveryAspect -> ItemId -> [CStore] -> Bool itemAffectsShineRadius discoAspect iid stores = (null stores || not (null $ intersect stores [CEqp, COrgan, CGround])) && case EM.lookup iid discoAspect of Just IA.AspectRecord{aShine} -> aShine /= 0 Nothing -> error $ "" `showFailure` iid itemAffectsPerRadius :: DiscoveryAspect -> ItemId -> Bool itemAffectsPerRadius discoAspect iid = case EM.lookup iid discoAspect of Just IA.AspectRecord{aSight, aSmell, aNocto} -> aSight /= 0 || aSmell /= 0 || aNocto /= 0 Nothing -> error $ "" `showFailure` iid addPerActor :: MonadServer m => ActorId -> Actor -> m () addPerActor aid b = do IA.AspectRecord{..} <- getsState $ getActorAspect aid unless (aSight <= 0 && aNocto <= 0 && aSmell <= 0) $ addPerActorAny aid b addPerActorAny :: MonadServer m => ActorId -> Actor -> m () addPerActorAny aid b = do let fid = bfid b lid = blid b f PerceptionCache{perActor} = PerceptionCache { ptotal = FovInvalid , perActor = EM.insert aid FovInvalid perActor } modifyServer $ \ser -> ser { sperCacheFid = EM.adjust (EM.adjust f lid) fid $ sperCacheFid ser , sperValidFid = EM.adjust (EM.insert lid False) fid $ sperValidFid ser } deletePerActor :: MonadServer m => ActorAspect -> ActorId -> Actor -> m () deletePerActor actorAspectOld aid b = do let IA.AspectRecord{..} = actorAspectOld EM.! aid unless (aSight <= 0 && aNocto <= 0 && aSmell <= 0) $ deletePerActorAny aid b deletePerActorAny :: MonadServer m => ActorId -> Actor -> m () deletePerActorAny aid b = do let fid = bfid b lid = blid b f PerceptionCache{perActor} = PerceptionCache { ptotal = FovInvalid , perActor = EM.delete aid perActor } modifyServer $ \ser -> ser { sperCacheFid = EM.adjust (EM.adjust f lid) fid $ sperCacheFid ser , sperValidFid = EM.adjust (EM.insert lid False) fid $ sperValidFid ser } invalidatePerActor :: MonadServer m => ActorId -> m () invalidatePerActor aid = do IA.AspectRecord{..} <- getsState $ getActorAspect aid unless (aSight <= 0 && aNocto <= 0 && aSmell <= 0) $ do b <- getsState $ getActorBody aid addPerActorAny aid b reconsiderPerActor :: MonadServer m => ActorId -> m () reconsiderPerActor aid = do b <- getsState $ getActorBody aid IA.AspectRecord{..} <- getsState $ getActorAspect aid if aSight <= 0 && aNocto <= 0 && aSmell <= 0 then do perCacheFid <- getsServer sperCacheFid when (EM.member aid $ perActor ((perCacheFid EM.! bfid b) EM.! blid b)) $ deletePerActorAny aid b else addPerActorAny aid b invalidatePerLid :: MonadServer m => LevelId -> m () invalidatePerLid lid = do let f pc@PerceptionCache{perActor} | EM.null perActor = pc | otherwise = PerceptionCache { ptotal = FovInvalid , perActor = EM.map (const FovInvalid) perActor } modifyServer $ \ser -> let perCacheFidNew = EM.map (EM.adjust f lid) $ sperCacheFid ser g fid valid | ptotal ((perCacheFidNew EM.! fid) EM.! lid) == FovInvalid = EM.insert lid False valid g _ valid = valid in ser { sperCacheFid = perCacheFidNew , sperValidFid = EM.mapWithKey g $ sperValidFid ser } LambdaHack-0.8.3.0/Game/LambdaHack/Server/ServerOptions.hs0000644000000000000000000000653213315545734021301 0ustar0000000000000000-- | Server and client game state types and operations. module Game.LambdaHack.Server.ServerOptions ( ServerOptions(..), RNGs(..), defServerOptions ) where import Prelude () import Game.LambdaHack.Common.Prelude import Data.Binary import qualified System.Random as R import Game.LambdaHack.Client (ClientOptions (..), defClientOptions) import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.Misc import Game.LambdaHack.Content.ModeKind -- | Options that affect the behaviour of the server (including game rules). data ServerOptions = ServerOptions { sknowMap :: Bool , sknowEvents :: Bool , sknowItems :: Bool , sniff :: Bool , sallClear :: Bool , sboostRandomItem :: Bool , sgameMode :: Maybe (GroupName ModeKind) , sautomateAll :: Bool , skeepAutomated :: Bool , sdungeonRng :: Maybe R.StdGen , smainRng :: Maybe R.StdGen , snewGameSer :: Bool , scurChalSer :: Challenge , sdumpInitRngs :: Bool , ssavePrefixSer :: String , sdbgMsgSer :: Bool , sclientOptions :: ClientOptions -- The client debug inside server debug only holds the client commandline -- options and is never updated with config options, etc. } deriving Show data RNGs = RNGs { dungeonRandomGenerator :: Maybe 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 instance Binary ServerOptions where put ServerOptions{..} = do put sknowMap put sknowEvents put sknowItems put sniff put sallClear put sboostRandomItem put sgameMode put sautomateAll put skeepAutomated put scurChalSer put ssavePrefixSer put sdbgMsgSer put sclientOptions get = do sknowMap <- get sknowEvents <- get sknowItems <- get sniff <- get sallClear <- get sboostRandomItem <- get sgameMode <- get sautomateAll <- get skeepAutomated <- get scurChalSer <- get ssavePrefixSer <- get sdbgMsgSer <- get sclientOptions <- get let sdungeonRng = Nothing smainRng = Nothing snewGameSer = False sdumpInitRngs = False return $! ServerOptions{..} instance Binary RNGs where put RNGs{..} = do put (show dungeonRandomGenerator) put (show startingRandomGenerator) get = do dg <- get sg <- get let dungeonRandomGenerator = read dg startingRandomGenerator = read sg return $! RNGs{..} -- | Default value of server options. defServerOptions :: ServerOptions defServerOptions = ServerOptions { sknowMap = False , sknowEvents = False , sknowItems = False , sniff = False , sallClear = False , sboostRandomItem = False , sgameMode = Nothing , sautomateAll = False , skeepAutomated = False , sdungeonRng = Nothing , smainRng = Nothing , snewGameSer = False , scurChalSer = defaultChallenge -- for debug; hard to set manually in browser: #ifdef USE_BROWSER , sdumpInitRngs = True #else , sdumpInitRngs = False #endif , ssavePrefixSer = "" , sdbgMsgSer = False , sclientOptions = defClientOptions } LambdaHack-0.8.3.0/Game/LambdaHack/Server/Commandline.hs0000644000000000000000000002231513315545734020702 0ustar0000000000000000{-# LANGUAGE ApplicativeDo #-} -- | Parsing of commandline arguments. module Game.LambdaHack.Server.Commandline ( serverOptionsPI #ifdef EXPOSE_INTERNAL -- * Internal operations , serverOptionsP -- other internal operations too numerous and changing, so not listed #endif ) where import Prelude () import Game.LambdaHack.Common.Prelude -- Cabal import qualified Paths_LambdaHack as Self (version) import qualified Data.Text as T import Data.Version import Options.Applicative import qualified System.Random as R -- Dependence on ClientOptions is an anomaly. Instead, probably the raw -- remaining commandline should be passed and parsed by the client to extract -- client and ui options from and singnal an error if anything was left. import Game.LambdaHack.Client (ClientOptions (..)) import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.Misc import Game.LambdaHack.Content.ModeKind import Game.LambdaHack.Server.ServerOptions -- | Parser for server options from commandline arguments. serverOptionsPI :: ParserInfo ServerOptions serverOptionsPI = info (serverOptionsP <**> helper <**> version) $ fullDesc <> progDesc "Configure debug options here, gameplay options in configuration file." version :: Parser (a -> a) version = infoOption (showVersion Self.version) ( long "version" <> help "Print engine version information" ) serverOptionsP :: Parser ServerOptions serverOptionsP = do ~(snewGameSer, scurChalSer) <- serToChallenge <$> newGameP knowMap <- knowMapP knowEvents <- knowEventsP knowItems <- knowItemsP sniff <- sniffP sallClear <- allClearP sboostRandomItem <- boostRandItemP sgameMode <- gameModeP sautomateAll <- automateAllP skeepAutomated <- keepAutomatedP sstopAfterSeconds <- stopAfterSecsP sstopAfterFrames <- stopAfterFramesP sprintEachScreen <- printEachScreenP sbenchmark <- benchmarkP sdungeonRng <- setDungeonRngP smainRng <- setMainRngP sdumpInitRngs <- dumpInitRngsP sdbgMsgSer <- dbgMsgSerP sgtkFontFamily <- gtkFontFamilyP sdlFontFile <- sdlFontFileP sdlTtfSizeAdd <- sdlTtfSizeAddP sdlFonSizeAdd <- sdlFonSizeAddP sfontSize <- fontSizeP sfontDir <- fontDirP scolorIsBold <- noColorIsBoldP slogPriority <- logPriorityP smaxFps <- maxFpsP sdisableAutoYes <- disableAutoYesP snoAnim <- noAnimP ssavePrefixSer <- savePrefixP sfrontendTeletype <- frontendTeletypeP sfrontendNull <- frontendNullP sfrontendLazy <- frontendLazyP sdbgMsgCli <- dbgMsgCliP pure ServerOptions { sclientOptions = ClientOptions { stitle = Nothing , snewGameCli = snewGameSer , ssavePrefixCli = ssavePrefixSer , .. } , sknowMap = knowMap || knowEvents || knowItems , sknowEvents = knowEvents || knowItems , sknowItems = knowItems , .. } where serToChallenge :: Maybe Int -> (Bool, Challenge) serToChallenge Nothing = (False, defaultChallenge) serToChallenge (Just cdiff) = (True, defaultChallenge {cdiff}) knowMapP :: Parser Bool knowMapP = switch ( long "knowMap" <> help "Reveal map for all clients in the next game" ) knowEventsP :: Parser Bool knowEventsP = switch ( long "knowEvents" <> help "Show all events in the next game (implies --knowMap)" ) knowItemsP :: Parser Bool knowItemsP = switch ( long "knowItems" <> help "Auto-identify all items in the next game (implies --knowEvents)" ) sniffP :: Parser Bool sniffP = switch ( long "sniff" <> help "Monitor all trafic between server and clients" ) allClearP :: Parser Bool allClearP = switch ( long "allClear" <> help "Let all map tiles be translucent" ) boostRandItemP :: Parser Bool boostRandItemP = switch ( long "boostRandomItem" <> help "Pick a random item and make it very common" ) gameModeP :: Parser (Maybe (GroupName ModeKind)) gameModeP = optional $ toGameMode <$> strOption ( long "gameMode" <> metavar "MODE" <> help "Start next game in the scenario indicated by MODE" ) where toGameMode :: String -> GroupName ModeKind toGameMode = toGroupName . T.pack automateAllP :: Parser Bool automateAllP = switch ( long "automateAll" <> help "Give control of all UI teams to computer" ) keepAutomatedP :: Parser Bool keepAutomatedP = switch ( long "keepAutomated" <> help "Keep factions automated after game over" ) newGameP :: Parser (Maybe Int) newGameP = optional $ option auto ( long "newGame" <> help "Start a new game, overwriting the save file, with difficulty for all UI players set to N" <> metavar "N" ) stopAfterSecsP :: Parser (Maybe Int) stopAfterSecsP = optional $ option auto ( long "stopAfterSeconds" <> help "Exit game session after around N seconds" <> metavar "N" ) stopAfterFramesP :: Parser (Maybe Int) stopAfterFramesP = optional $ option auto ( long "stopAfterFrames" <> help "Exit game session after around N frames" <> metavar "N" ) printEachScreenP :: Parser Bool printEachScreenP = switch ( long "printEachScreen" <> help "Take a screenshot of each rendered distinct frame (SDL only)" ) benchmarkP :: Parser Bool benchmarkP = switch ( long "benchmark" <> help "Restrict file IO, print timing stats" ) setDungeonRngP :: Parser (Maybe R.StdGen) setDungeonRngP = optional $ option auto ( long "setDungeonRng" <> metavar "RNG_SEED" <> help "Set dungeon generation RNG seed to string RNG_SEED" ) setMainRngP :: Parser (Maybe R.StdGen) setMainRngP = optional $ option auto ( long "setMainRng" <> metavar "RNG_SEED" <> help "Set the main game RNG seed to string RNG_SEED" ) dumpInitRngsP :: Parser Bool dumpInitRngsP = switch ( long "dumpInitRngs" <> help "Dump the RNG seeds used to initialize the game" ) dbgMsgSerP :: Parser Bool dbgMsgSerP = switch ( long "dbgMsgSer" <> help "Emit extra internal server debug messages" ) gtkFontFamilyP :: Parser (Maybe Text) gtkFontFamilyP = optional $ T.pack <$> strOption ( long "gtkFontFamily" <> metavar "FONT_FAMILY" <> help "Use FONT_FAMILY for the main game window in GTK frontend" ) sdlFontFileP :: Parser (Maybe Text) sdlFontFileP = optional $ T.pack <$> strOption ( long "sdlFontFile" <> metavar "FONT_FILE" <> help "Use FONT_FILE for the main game window in SDL2 frontend" ) sdlTtfSizeAddP :: Parser (Maybe Int) sdlTtfSizeAddP = optional $ option auto ( long "sdlTtfSizeAdd" <> metavar "N" <> help "Enlarge map cells by N over scalable font max height in SDL2 frontend" ) sdlFonSizeAddP :: Parser (Maybe Int) sdlFonSizeAddP = optional $ option auto ( long "sdlFonSizeAdd" <> metavar "N" <> help "Enlarge map cells by N on top of .fon font max height in SDL2 frontend" ) fontSizeP :: Parser (Maybe Int) fontSizeP = optional $ option auto ( long "fontSize" <> metavar "N" <> help "Use font size N for the main game window (interpreted differently by different graphical frontends)" ) fontDirP :: Parser (Maybe FilePath) fontDirP = optional $ option auto ( long "fontDir" <> metavar "FILEPATH" <> help "Take font files for the SDL2 frontend from FILEPATH" ) noColorIsBoldP :: Parser (Maybe Bool) noColorIsBoldP = flag Nothing (Just False) ( long "noColorIsBold" <> help "Refrain from making some bright color characters bolder" ) maxFpsP :: Parser (Maybe Int) maxFpsP = optional $ max 1 <$> option auto ( long "maxFps" <> metavar "N" <> help "Display at most N frames per second" ) logPriorityP :: Parser (Maybe Int) logPriorityP = optional $ max 1 <$> option auto ( long "logPriority" <> metavar "N" <> help "Log only messages of priority at least N, where 1 (all) is the lowest and 5 (errors only) is the default." ) disableAutoYesP :: Parser Bool disableAutoYesP = switch ( long "disableAutoYes" <> help "Never auto-answer prompts, not even when UI faction is automated" ) noAnimP :: Parser (Maybe Bool) noAnimP = flag Nothing (Just True) ( long "noAnim" <> help "Don't show any animations" ) savePrefixP :: Parser String savePrefixP = strOption ( long "savePrefix" <> metavar "PREFIX" <> value "" <> help "Prepend PREFIX to all savefile names" ) frontendTeletypeP :: Parser Bool frontendTeletypeP = switch ( long "frontendTeletype" <> help "Use the line terminal frontend (for tests)" ) frontendNullP :: Parser Bool frontendNullP = switch ( long "frontendNull" <> help "Use frontend with no display (for benchmarks)" ) frontendLazyP :: Parser Bool frontendLazyP = switch ( long "frontendLazy" <> help "Use frontend that not even computes frames (for benchmarks)" ) dbgMsgCliP :: Parser Bool dbgMsgCliP = switch ( long "dbgMsgCli" <> help "Emit extra internal client debug messages" ) LambdaHack-0.8.3.0/Game/LambdaHack/Server/DungeonGen/0000755000000000000000000000000013315545734020146 5ustar0000000000000000LambdaHack-0.8.3.0/Game/LambdaHack/Server/DungeonGen/Place.hs0000644000000000000000000003453713315545734021542 0ustar0000000000000000{-# LANGUAGE RankNTypes #-} -- | Generation of places from place kinds. module Game.LambdaHack.Server.DungeonGen.Place ( Place(..), TileMapEM, placeCheck, buildPlace, isChancePos, buildFenceRnd #ifdef EXPOSE_INTERNAL -- * Internal operations , interiorArea, olegend, ooverride, buildFence, tilePlace #endif ) where import Prelude () import Game.LambdaHack.Common.Prelude import Data.Binary import qualified Data.Bits as Bits import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES import qualified Data.Text as T import qualified Game.LambdaHack.Common.Dice as Dice import Game.LambdaHack.Common.Frequency import Game.LambdaHack.Common.Kind import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.Random import qualified Game.LambdaHack.Common.Tile as Tile import Game.LambdaHack.Content.CaveKind import Game.LambdaHack.Content.PlaceKind import Game.LambdaHack.Content.TileKind (TileKind) import qualified Game.LambdaHack.Content.TileKind as TK import Game.LambdaHack.Server.DungeonGen.Area -- | The parameters of a place. All are immutable and rolled and fixed -- at the time when a place is generated. data Place = Place { qkind :: ContentId PlaceKind , qarea :: Area , qseen :: Bool , qlegend :: GroupName TileKind , qFWall :: ContentId TileKind , qFFloor :: ContentId TileKind , qFGround :: ContentId 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 (ContentId 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 pk@PlaceKind{..} = case interiorArea pk 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 -> True CMirror -> True -- | Calculate interior room area according to fence type, based on the -- total area for the room and it's fence. This is used for checking -- if the room fits in the area, for digging up the place and the fence -- and for deciding if the room is dark or lit later in the dungeon -- generation process. interiorArea :: PlaceKind -> Area -> Maybe Area interiorArea kr r = let requiredForFence = case pfence kr of FWall -> 1 FFloor -> 1 FGround -> 1 FNone -> 0 in if pcover kr `elem` [CVerbatim, CMirror] then let (x0, y0, x1, y1) = fromArea r dx = case ptopLeft kr of [] -> error $ "" `showFailure` kr l : _ -> T.length l dy = length $ ptopLeft kr mx = (x1 - x0 + 1 - dx) `div` 2 my = (y1 - y0 + 1 - dy) `div` 2 in if mx < requiredForFence || my < requiredForFence then Nothing else toArea (x0 + mx, y0 + my, x0 + mx + dx - 1, y0 + my + dy - 1) else case requiredForFence of 0 -> Just r 1 -> shrink r _ -> error $ "" `showFailure` kr -- | Given a few parameters, roll and construct a 'Place' datastructure -- and fill a cave section acccording to it. buildPlace :: COps -- ^ the game content -> CaveKind -- ^ current cave kind -> Bool -- ^ whether the cave is dark -> ContentId TileKind -- ^ dark fence tile, if fence hollow -> ContentId TileKind -- ^ lit fence tile, if fence hollow -> Dice.AbsDepth -- ^ current level depth -> Dice.AbsDepth -- ^ absolute depth -> Int -- ^ secret tile seed -> Area -- ^ whole area of the place, fence included -> Maybe (GroupName PlaceKind) -- ^ optional fixed place group -> Rnd (TileMapEM, Place) buildPlace cops@COps{cotile, coplace} CaveKind{..} dnight darkCorTile litCorTile ldepth@(Dice.AbsDepth ld) totalDepth@(Dice.AbsDepth depth) dsecret r mplaceGroup = do qFWall <- fromMaybe (error $ "" `showFailure` cfillerTile) <$> opick cotile cfillerTile (const True) 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) f !placeGroup !q !acc !p !pk !kind = let rarity = linearInterpolation (prarity kind) in (q * p * rarity, ((pk, kind), placeGroup)) : acc g (placeGroup, q) = ofoldlGroup' coplace placeGroup (f placeGroup q) [] pfreq = case mplaceGroup of Nothing -> cplaceFreq Just placeGroup -> [(placeGroup, 1)] placeFreq = concatMap g pfreq 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 dark <- if cpassable && pfence kr `elem` [FFloor, FGround] then return dnight else chanceDice ldepth totalDepth cdarkChance 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 (error $ "" `showFailure` (kr, r)) $ interiorArea kr r place = Place {..} (overrideOneIn, override) <- ooverride cops (poverride kr) (legendOneIn, legend) <- olegend cops qlegend (legendLitOneIn, legendLit) <- olegend cops clegendLitTile let xlegend = ( EM.union overrideOneIn legendOneIn , EM.union override legend ) xlegendLit = ( EM.union overrideOneIn legendLitOneIn , EM.union override legendLit ) cmap <- tilePlace qarea kr let 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 = lookupOneIn xlegendLit xy c | otherwise = lookupOneIn xlegend xy c lookupOneIn :: ( EM.EnumMap Char (Int, ContentId TileKind) , EM.EnumMap Char (ContentId TileKind) ) -> Point -> Char -> ContentId TileKind lookupOneIn (mOneIn, m) xy c = case EM.lookup c mOneIn of Just (oneInChance, tk) -> if isChancePos oneInChance dsecret xy then tk else EM.findWithDefault (error $ "" `showFailure` (c, mOneIn, m)) c m Nothing -> EM.findWithDefault (error $ "" `showFailure` (c, mOneIn, m)) c m interior = case pfence kr of FNone | not dnight -> EM.mapWithKey digDay cmap _ -> EM.mapWithKey (lookupOneIn xlegend) cmap return (EM.union interior fence, place) isChancePos :: Int -> Int -> Point -> Bool isChancePos c dsecret (Point x y) = c > 0 && (dsecret `Bits.rotateR` x `Bits.xor` y + x) `mod` c == 0 -- | Roll a legend of a place plan: a map from plan symbols to tile kinds. olegend :: COps -> GroupName TileKind -> Rnd ( EM.EnumMap Char (Int, ContentId TileKind) , EM.EnumMap Char (ContentId TileKind) ) olegend COps{cotile} cgroup = let getSymbols !acc _ !tk = maybe acc (const $ ES.insert (TK.tsymbol tk) acc) (lookup cgroup $ TK.tfreq tk) symbols = ofoldlWithKey' cotile getSymbols ES.empty getLegend s !acc = do (mOneIn, m) <- acc let p f t = TK.tsymbol t == s && f (Tile.kindHasFeature TK.Spice t) tk <- fmap (fromMaybe $ error $ "" `showFailure` (cgroup, s)) $ opick cotile cgroup (p not) mtkSpice <- opick cotile cgroup (p id) return $! case mtkSpice of Nothing -> (mOneIn, EM.insert s tk m) Just tkSpice -> let n = fromJust (lookup cgroup (TK.tfreq (okind cotile tk))) k = fromJust (lookup cgroup (TK.tfreq (okind cotile tkSpice))) oneIn = (n + k) `divUp` k in (EM.insert s (oneIn, tkSpice) mOneIn, EM.insert s tk m) legend = ES.foldr' getLegend (return (EM.empty, EM.empty)) symbols in legend ooverride :: COps -> [(Char, GroupName TileKind)] -> Rnd ( EM.EnumMap Char (Int, ContentId TileKind) , EM.EnumMap Char (ContentId TileKind) ) ooverride COps{cotile} poverride = let getLegend (s, cgroup) acc = do (mOneIn, m) <- acc mtkSpice <- opick cotile cgroup (Tile.kindHasFeature TK.Spice) tk <- fromMaybe (error $ "" `showFailure` (s, cgroup, poverride)) <$> opick cotile cgroup (not . Tile.kindHasFeature TK.Spice) return $! case mtkSpice of Nothing -> (mOneIn, EM.insert s tk m) Just tkSpice -> let n = fromJust (lookup cgroup (TK.tfreq (okind cotile tk))) k = fromJust (lookup cgroup (TK.tfreq (okind cotile tkSpice))) oneIn = (n + k) `divUp` k in (EM.insert s (oneIn, tkSpice) mOneIn, EM.insert s tk m) in foldr getLegend (return (EM.empty, EM.empty)) poverride -- | Construct a fence around an area, with the given tile kind. buildFence :: ContentId 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 :: COps -> GroupName TileKind -> Area -> Rnd TileMapEM buildFenceRnd COps{cotile} 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 (error $ "" `showFailure` tileGroup) <$> opick cotile 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 -- | Create a place by tiling patterns. tilePlace :: Area -- ^ the area to fill -> PlaceKind -- ^ the place kind to construct -> Rnd (EM.EnumMap Point Char) tilePlace area pl@PlaceKind{..} = do let (x0, y0, x1, y1) = fromArea area xwidth = x1 - x0 + 1 ywidth = y1 - y0 + 1 dxcorner = case ptopLeft of [] -> error $ "" `showFailure` (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 :: (Int -> String -> String) -> (Int -> [String] -> [String]) -> [(Point, Char)] fillInterior f g = 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 gy = g dy $ map T.unpack ptopLeft yStart = y0 + ((ywidth - length gy) `div` 2) in zip [yStart..] gy in concatMap tileInterior reflected tileReflect :: Int -> [a] -> [a] tileReflect d pat = let lstart = take (d `divUp` 2) pat lend = take (d `div` 2) pat in lstart ++ reverse lend interior <- case pcover of CAlternate -> do let tile :: Int -> [a] -> [a] tile _ [] = error $ "nothing to tile" `showFailure` pl tile d pat = take d (cycle $ init pat ++ init (reverse pat)) return $! fillInterior tile tile CStretch -> do let stretch :: Int -> [a] -> [a] stretch _ [] = error $ "nothing to stretch" `showFailure` pl stretch d pat = tileReflect d (pat ++ repeat (last pat)) return $! fillInterior stretch stretch CReflect -> do let reflect :: Int -> [a] -> [a] reflect d pat = tileReflect d (cycle pat) return $! fillInterior reflect reflect CVerbatim -> return $! fillInterior (flip const) (flip const) CMirror -> do mirror1 <- oneOf [id, reverse] mirror2 <- oneOf [id, reverse] return $! fillInterior (\_ l -> mirror1 l) (\_ l -> mirror2 l) return $! 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.8.3.0/Game/LambdaHack/Server/DungeonGen/Cave.hs0000644000000000000000000004027313315545734021366 0ustar0000000000000000-- | Generation of caves (not yet inhabited dungeon levels) from cave kinds. module Game.LambdaHack.Server.DungeonGen.Cave ( Cave(..), anchorDown, bootFixedCenters, buildCave #ifdef EXPOSE_INTERNAL -- * Internal operations , pickOpening, digCorridors #endif ) where import Prelude () import Game.LambdaHack.Common.Prelude import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES import Data.Key (mapWithKeyM) import qualified Game.LambdaHack.Common.Dice as Dice import Game.LambdaHack.Common.Kind import Game.LambdaHack.Common.Misc 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 :: ContentId CaveKind -- ^ the kind of the cave , dsecret :: Int -- ^ secret tile seed , dmap :: TileMapEM -- ^ tile kinds in the cave , dplaces :: [Place] -- ^ places generated in the cave , dnight :: Bool -- ^ whether the cave is dark } deriving Show anchorDown :: Y anchorDown = 5 -- not 4, asymmetric vs up, for staircase variety bootFixedCenters :: CaveKind -> [Point] bootFixedCenters CaveKind{..} = [Point 4 3, Point (cxsize - 5) (cysize - anchorDown)] {- | Generate a cave using an algorithm inspired by the original Rogue, as follows (in gross simplification): * The available area is divided into a grid, e.g, 3 by 3, where each of the 9 grid cells has approximately the same size. * In some of the 9 grid cells a room is placed at a random position and with a random size, but larger than the minimum size, e.g, 2 by 2 floor tiles. * Rooms that are on horizontally or vertically adjacent grid cells may be connected by a corridor. Corridors consist of 3 segments of straight lines (either "horizontal, vertical, horizontal" or "vertical, horizontal, vertical"). They end in openings in the walls of the room they connect. It is possible that one or two of the 3 segments have length 0, such that the resulting corridor is L-shaped or even a single straight line. * Corridors are generated randomly in such a way that at least every room on the grid is connected, and a few more might be. It is not sufficient to always connect all adjacent rooms, because not each cell holds a room. -} buildCave :: COps -- ^ content definitions -> Dice.AbsDepth -- ^ depth of the level to generate -> Dice.AbsDepth -- ^ absolute depth -> Int -- ^ secret tile seed -> ContentId CaveKind -- ^ cave kind to use for generation -> EM.EnumMap Point (GroupName PlaceKind) -- ^ pos of stairs, etc. -> Rnd Cave buildCave cops@COps{cotile, cocave, coplace, coTileSpeedup} ldepth totalDepth dsecret dkind fixedCenters = do let kc@CaveKind{..} = okind cocave dkind lgrid' <- 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 (error $ "" `showFailure` kc) $ toArea (0, 0, cxsize - 1, cysize - 1) subFullArea = fromMaybe (error $ "" `showFailure` kc) $ toArea (1, 1, cxsize - 2, cysize - 2) darkCorTile <- fromMaybe (error $ "" `showFailure` cdarkCorTile) <$> opick cotile cdarkCorTile (const True) litCorTile <- fromMaybe (error $ "" `showFailure` clitCorTile) <$> opick cotile clitCorTile (const True) dnight <- chanceDice ldepth totalDepth cnightChance let createPlaces lgr' = do let area | couterFenceTile /= "basic outer fence" = subFullArea | otherwise = fullArea (lgr@(gx, gy), gs) = grid fixedCenters (bootFixedCenters kc) lgr' area minPlaceSize <- castDiceXY ldepth totalDepth cminPlaceSize maxPlaceSize <- castDiceXY ldepth totalDepth cmaxPlaceSize let mergeFixed :: EM.EnumMap Point SpecialArea -> (Point, SpecialArea) -> EM.EnumMap Point SpecialArea mergeFixed !gs0 (!i, !special) = let mergeSpecial ar p2 f = case EM.lookup p2 gs0 of Just (SpecialArea ar2) -> let aSum = sumAreas ar ar2 sp = SpecialMerged (f aSum) p2 in EM.insert i sp $ EM.delete p2 gs0 _ -> gs0 mergable :: X -> Y -> Maybe HV mergable x y = case EM.lookup (Point x y) gs0 of Just (SpecialArea ar) -> let (x0, y0, x1, y1) = fromArea ar isFixed p = case gs EM.! p of SpecialFixed{} -> True _ -> False in if -- Limit (the aggresive) merging of normal places -- and leave extra place for merging stairs. | any isFixed $ vicinityCardinal gx gy (Point x y) -> Nothing -- Bias: prefer extending vertically. -- Not @-1@, but @-3@, to merge aggressively. | y1 - y0 - 3 < snd minPlaceSize -> Just Vert | x1 - x0 - 3 < fst minPlaceSize -> Just Horiz | otherwise -> Nothing _ -> Nothing in case special of SpecialArea ar -> case mergable (px i) (py i) of Nothing -> gs0 Just hv -> case hv of -- Bias; vertical minimal sizes are smaller. Vert | py i - 1 >= 0 && mergable (px i) (py i - 1) == Just Vert -> mergeSpecial ar i{py = py i - 1} SpecialArea Vert | py i + 1 < gy && mergable (px i) (py i + 1) == Just Vert -> mergeSpecial ar i{py = py i + 1} SpecialArea Horiz | px i - 1 >= 0 && mergable (px i - 1) (py i) == Just Horiz -> mergeSpecial ar i{px = px i - 1} SpecialArea Horiz | px i + 1 < gx && mergable (px i + 1) (py i) == Just Horiz -> mergeSpecial ar i{px = px i + 1} SpecialArea _ -> gs0 SpecialFixed p placeGroup ar -> -- If single merge is sufficient to extend the fixed place -- to full size, and the merge is possible, we perform it. -- An empty inner list signifies some merge is needed, -- but not possible, and then we abort and don't waste space. let (x0, y0, x1, y1) = fromArea ar d = 3 -- arbitrary, matches common content vics :: [[Point]] vics = [ [i {py = py i - 1} | py i - 1 >= 0] -- possible | py p - y0 < d ] -- needed ++ [ [i {py = py i + 1} | py i + 1 < gy] | y1 - py p < d ] ++ [ [i {px = px i - 1} | px i - 1 >= 0] | px p - x0 < d ] ++ [ [i {px = px i + 1} | px i + 1 < gx] | x1 - px p < d ] in case vics of [[p2]] -> mergeSpecial ar p2 (SpecialFixed p placeGroup) _ -> gs0 SpecialMerged{} -> error $ "" `showFailure` (gs, gs0, i) gs2 = foldl' mergeFixed gs $ EM.assocs gs voidPlaces <- do let gridArea = fromMaybe (error $ "" `showFailure` lgr) $ toArea (0, 0, gx - 1, gy - 1) voidNum = round $ cmaxVoid * fromIntegral (EM.size gs2) isOrdinaryArea p = case p `EM.lookup` gs2 of Just SpecialArea{} -> True _ -> False reps <- replicateM voidNum (xyInArea gridArea) -- repetitions are OK; variance is low anyway return $! ES.fromList $ filter isOrdinaryArea reps let decidePlace :: Bool -> ( TileMapEM, [Place] , EM.EnumMap Point (Area, Fence, Area) ) -> (Point, SpecialArea) -> Rnd ( TileMapEM, [Place] , EM.EnumMap Point (Area, Fence, Area) ) decidePlace noVoid (!m, !pls, !qls) (!i, !special) = case special of SpecialArea ar -> do -- Reserved for corridors and the global fence. let innerArea = fromMaybe (error $ "" `showFailure` (i, ar)) $ shrink ar !_A0 = shrink innerArea !_A1 = assert (isJust _A0 `blame` (innerArea, gs2)) () if not noVoid && i `ES.member` voidPlaces then do r <- mkVoidRoom innerArea return (m, pls, EM.insert i (r, FNone, ar) qls) else do r <- mkRoom minPlaceSize maxPlaceSize innerArea (tmap, place) <- buildPlace cops kc dnight darkCorTile litCorTile ldepth totalDepth dsecret r Nothing let fence = pfence $ okind coplace $ qkind place return ( EM.union tmap m , place : pls , EM.insert i (qarea place, fence, ar) qls ) SpecialFixed p@Point{..} placeGroup ar -> do -- Reserved for corridors and the global fence. let innerArea = fromMaybe (error $ "" `showFailure` (i, ar)) $ shrink ar !_A0 = shrink innerArea !_A1 = assert (isJust _A0 `blame` (innerArea, gs2)) () !_A2 = assert (p `inside` fromArea (fromJust _A0) `blame` (p, innerArea, fixedCenters)) () r = mkFixed maxPlaceSize innerArea p !_A3 = assert (isJust (shrink r) `blame` ( r, p, innerArea, ar , gs2, qls, fixedCenters )) () (tmap, place) <- buildPlace cops kc dnight darkCorTile litCorTile ldepth totalDepth dsecret r (Just placeGroup) let fence = pfence $ okind coplace $ qkind place return ( EM.union tmap m , place : pls , EM.insert i (qarea place, fence, ar) qls ) SpecialMerged sp p2 -> do (lplaces, dplaces, qplaces) <- decidePlace True (m, pls, qls) (i, sp) return ( lplaces, dplaces , EM.insert p2 (qplaces EM.! i) qplaces ) places <- foldlM' (decidePlace False) (EM.empty, [], EM.empty) $ EM.assocs gs2 return (voidPlaces, lgr, places) (voidPlaces, lgrid, (lplaces, dplaces, qplaces)) <- createPlaces lgrid' let lcorridorsFun lgr = do connects <- connectGrid voidPlaces lgr addedConnects <- do let cauxNum = round $ cauxConnects * fromIntegral (fst lgr * snd lgrid) cns <- nub . sort <$> replicateM cauxNum (randomConnection lgr) -- This allows connections through a single void room, -- if a non-void room on both ends. let notDeadEnd (p, q) = if | p `ES.member` voidPlaces -> q `ES.notMember` voidPlaces && sndInCns p | q `ES.member` voidPlaces -> fstInCns q | otherwise -> True sndInCns p = any (\(p0, q0) -> q0 == p && p0 `ES.notMember` voidPlaces) cns fstInCns q = any (\(p0, q0) -> p0 == q && q0 `ES.notMember` voidPlaces) cns return $! filter notDeadEnd cns let allConnects = connects `union` addedConnects connectPos :: (Point, Point) -> Rnd (Maybe Corridor) connectPos (p0, p1) = connectPlaces (qplaces EM.! p0) (qplaces EM.! p1) cs <- catMaybes <$> mapM connectPos allConnects let pickedCorTile = if dnight then darkCorTile else litCorTile return $! EM.unions (map (digCorridors pickedCorTile) cs) lcorridors <- lcorridorsFun lgrid let doorMapFun lpl lcor = do -- The hacks below are instead of unionWithKeyM, which is costly. let mergeCor _ pl cor = if Tile.isWalkable coTileSpeedup pl then Nothing -- tile already open else Just (Tile.buildAs cotile pl, cor) intersectionWithKeyMaybe combine = EM.mergeWithKey combine (const EM.empty) (const EM.empty) interCor = intersectionWithKeyMaybe mergeCor lpl lcor -- fast mapWithKeyM (pickOpening cops kc lplaces litCorTile dsecret) interCor -- very small doorMap <- doorMapFun lplaces lcorridors fence <- buildFenceRnd cops couterFenceTile subFullArea -- The obscured tile, e.g., scratched wall, stays on the server forever, -- only the suspect variant on client gets replaced by this upon searching. let obscure p t = if isChancePos chidden dsecret p && likelySecret p then Tile.obscureAs cotile $ Tile.buildAs cotile t else return t likelySecret Point{..} = px > 2 && px < cxsize - 3 && py > 2 && py < cysize - 3 umap = EM.unions [doorMap, lplaces, lcorridors, fence] -- order matters dmap <- mapWithKeyM obscure umap return $! Cave {dkind, dsecret, dmap, dplaces, dnight} pickOpening :: COps -> CaveKind -> TileMapEM -> ContentId TileKind -> Int -> Point -> (ContentId TileKind, ContentId TileKind) -> Rnd (ContentId TileKind) pickOpening COps{cotile, coTileSpeedup} CaveKind{cxsize, cysize, cdoorChance, copenChance, chidden} lplaces litCorTile dsecret pos (hidden, cor) = do let nicerCorridor = if Tile.isLit coTileSpeedup cor then cor else -- If any cardinally adjacent room tile lit, make the opening lit. let roomTileLit p = case EM.lookup p lplaces of Nothing -> False Just tile -> Tile.isLit coTileSpeedup tile vic = vicinityCardinal cxsize cysize pos in if any roomTileLit vic then litCorTile else cor -- Openings have a certain chance to be doors and doors have a certain -- chance to be open. rd <- chance cdoorChance if rd then do doorTrappedId <- Tile.revealAs cotile hidden -- Not all solid tiles can hide a door, so @doorTrappedId@ may in fact -- not be a door at all, hence the check. if Tile.isDoor coTileSpeedup doorTrappedId then do -- door created ro <- chance copenChance if ro then Tile.openTo cotile doorTrappedId else if isChancePos chidden dsecret pos then return $! doorTrappedId -- will become hidden else do doorOpenId <- Tile.openTo cotile doorTrappedId Tile.closeTo cotile doorOpenId else return $! doorTrappedId -- assume this is what content enforces else return $! nicerCorridor digCorridors :: ContentId 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.8.3.0/Game/LambdaHack/Server/DungeonGen/AreaRnd.hs0000644000000000000000000002307113315545734022021 0ustar0000000000000000-- | Operations on the 'Area' type that involve random numbers. module Game.LambdaHack.Server.DungeonGen.AreaRnd ( -- * Picking points inside areas xyInArea, mkVoidRoom, mkRoom -- * Choosing connections , connectGrid, randomConnection -- * Plotting corridors , HV(..), Corridor, connectPlaces #ifdef EXPOSE_INTERNAL -- * Internal operations , connectGrid', sortPoint, mkCorridor, borderPlace #endif ) where import Prelude () import Game.LambdaHack.Common.Prelude import qualified Data.EnumSet as ES import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.Random import Game.LambdaHack.Common.Vector import Game.LambdaHack.Content.PlaceKind 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 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 -- | Create a random room according to given parameters. mkRoom :: (X, Y) -- ^ minimum size -> (X, Y) -- ^ maximum size -> Area -- ^ the containing area, not the room itself -> Rnd Area mkRoom (xm, ym) (xM, yM) area = do let (x0, y0, x1, y1) = fromArea area xspan = x1 - x0 + 1 yspan = y1 - y0 + 1 aW = (min xm xspan, min ym yspan, min xM xspan, min yM yspan) areaW = fromMaybe (error $ "" `showFailure` aW) $ toArea aW Point xW yW <- xyInArea areaW -- roll size let a1 = (x0, y0, max x0 (x1 - xW + 1), max y0 (y1 - yW + 1)) area1 = fromMaybe (error $ "" `showFailure` a1) $ toArea a1 Point rx1 ry1 <- xyInArea area1 -- roll top-left corner let a3 = (rx1, ry1, rx1 + xW - 1, ry1 + yW - 1) area3 = fromMaybe (error $ "" `showFailure` a3) $ toArea a3 return $! area3 -- Choosing connections between areas in a grid -- | Pick a subset of connections between adjacent areas within a grid until -- there is only one connected component in the graph of all areas. connectGrid :: ES.EnumSet Point -> (X, Y) -> Rnd [(Point, Point)] connectGrid voidPlaces (nx, ny) = do let unconnected = ES.fromDistinctAscList [ Point x y | y <- [0..ny-1], x <- [0..nx-1] ] -- Candidates are neighbours that are still unconnected. We start with -- a random choice. p <- oneOf $ ES.toList $ unconnected ES.\\ voidPlaces let candidates = ES.singleton p connectGrid' voidPlaces (nx, ny) unconnected candidates [] connectGrid' :: ES.EnumSet Point -> (X, Y) -> ES.EnumSet Point -> ES.EnumSet Point -> [(Point, Point)] -> Rnd [(Point, Point)] connectGrid' voidPlaces (nx, ny) unconnected candidates !acc | unconnected `ES.isSubsetOf` voidPlaces = return acc | otherwise = do let candidatesBest = candidates ES.\\ voidPlaces c <- oneOf $ ES.toList $ if ES.null candidatesBest then candidates else candidatesBest -- potential new candidates: let ns = ES.fromList $ vicinityCardinal nx ny c nu = ES.delete c unconnected -- new unconnected -- (new candidates, potential connections): (nc, ds) = ES.partition (`ES.member` nu) ns new <- if ES.null ds then return id else do d <- oneOf (ES.toList ds) return (sortPoint (c, d) :) connectGrid' voidPlaces (nx, ny) nu (ES.delete c (candidates `ES.union` nc)) (new acc) -- | Sort the sequence of two points, in the derived lexicographic order. sortPoint :: (Point, Point) -> (Point, Point) sortPoint (a, b) | a <= b = (a, b) | otherwise = (b, a) -- | Pick a single random connection between adjacent areas within a grid. randomConnection :: (X, Y) -> Rnd (Point, Point) randomConnection (nx, ny) = assert (nx > 1 && ny > 0 || nx > 0 && ny > 1 `blame` (nx, ny)) $ do rb <- oneOf [False, True] if rb || 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 deriving Eq -- | 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. -- There might not always exist a good intermediate point -- if the places are allowed to be close together -- and then we let the intermediate part degenerate. mkCorridor :: HV -- ^ orientation of the starting section -> Point -- ^ starting point -> Bool -- ^ starting is inside @FGround@ or @FFloor@ -> Point -- ^ ending point -> Bool -- ^ ending is inside @FGround@ or @FFloor@ -> Area -- ^ the area containing the intermediate point -> Rnd Corridor -- ^ straight sections of the corridor mkCorridor hv (Point x0 y0) p0floor (Point x1 y1) p1floor area = do Point rxRaw ryRaw <- xyInArea area let (sx0, sy0, sx1, sy1) = fromArea area -- Avoid corridors that run along @FGround@ or @FFloor@ fence. rx = if | rxRaw == sx0 + 1 && p0floor -> sx0 | rxRaw == sx1 - 1 && p1floor -> sx1 | otherwise -> rxRaw ry = if | ryRaw == sy0 + 1 && p0floor -> sy0 | ryRaw == sy1 - 1 && p1floor -> sy1 | otherwise -> ryRaw return $! 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 some steps away from the edges, if the place -- is big enough. Note that with @pfence == FNone@, the inner area considered -- is the strict interior of the place, without the outermost tiles. -- -- The corridor connects (touches) the inner areas and the turning point -- of the corridor (if any) is outside of the outer areas -- and inside the grid areas. connectPlaces :: (Area, Fence, Area) -> (Area, Fence, Area) -> Rnd (Maybe Corridor) connectPlaces (_, _, sg) (_, _, tg) | sg == tg = return Nothing connectPlaces s3@(sqarea, spfence, sg) t3@(tqarea, tpfence, tg) = do let (sa, so) = borderPlace sqarea spfence (ta, to) = borderPlace tqarea tpfence trim area = let (x0, y0, x1, y1) = fromArea area dx = case (x1 - x0) `div` 2 of 0 -> 0 1 -> 1 2 -> 1 3 -> 1 _ -> 3 dy = case (y1 - y0) `div` 2 of 0 -> 0 1 -> 1 2 -> 1 3 -> 1 _ -> 3 in fromMaybe (error $ "" `showFailure` (area, s3, t3)) $ toArea (x0 + dx, y0 + dy, x1 - dx, y1 - dy) Point sx sy <- xyInArea $ trim sa Point tx ty <- xyInArea $ trim ta -- If the place (e.g., void place) is trivial (1-tile wide, no fence), -- overwrite it with corridor. The place may not even be built (e.g., void) -- and the overwrite ensures connections through it are not broken. let (_, _, sax1Raw, say1Raw) = fromArea sa -- inner area strivial = isTrivialArea sqarea && spfence == FNone (sax1, say1) = if strivial then (sax1Raw - 1, say1Raw - 1) else (sax1Raw, say1Raw) (tax0Raw, tay0Raw, _, _) = fromArea ta ttrivial = isTrivialArea tqarea && tpfence == FNone (tax0, tay0) = if ttrivial then (tax0Raw + 1, tay0Raw + 1) else (tax0Raw, tay0Raw) (_, _, sox1, soy1) = fromArea so -- outer area (tox0, toy0, _, _) = fromArea to (sgx0, sgy0, sgx1, sgy1) = fromArea sg -- grid area (tgx0, tgy0, tgx1, tgy1) = fromArea tg (hv, area, p0, p1) | sgx1 == tgx0 = let x0 = if sgy0 <= ty && ty <= sgy1 then sox1 + 1 else sgx1 x1 = if tgy0 <= sy && sy <= tgy1 then tox0 - 1 else sgx1 in case toArea (x0, min sy ty, x1, max sy ty) of Just a -> (Horiz, a, Point (sax1 + 1) sy, Point (tax0 - 1) ty) Nothing -> error $ "" `showFailure` (sx, sy, tx, ty, s3, t3) | otherwise = assert (sgy1 == tgy0) $ let y0 = if sgx0 <= tx && tx <= sgx1 then soy1 + 1 else sgy1 y1 = if tgx0 <= sx && sx <= tgx1 then toy0 - 1 else sgy1 in case toArea (min sx tx, y0, max sx tx, y1) of Just a -> (Vert, a, Point sx (say1 + 1), Point tx (tay0 - 1)) Nothing -> error $ "" `showFailure` (sx, sy, tx, ty, s3, t3) nin p = not $ p `inside` fromArea sa || p `inside` fromArea ta !_A = assert (strivial || ttrivial || allB nin [p0, p1]`blame` (sx, sy, tx, ty, s3, t3)) () cor <- mkCorridor hv p0 (sa == so) p1 (ta == to) area let !_A2 = assert (strivial || ttrivial || allB nin cor `blame` (sx, sy, tx, ty, s3, t3)) () return $ Just cor borderPlace :: Area -> Fence -> (Area, Area) borderPlace qarea pfence = case pfence of FWall -> (qarea, expand qarea) FFloor -> (qarea, qarea) FGround -> (qarea, qarea) FNone -> case shrink qarea of Nothing -> (qarea, qarea) Just sr -> (sr, qarea) LambdaHack-0.8.3.0/Game/LambdaHack/Server/DungeonGen/Area.hs0000644000000000000000000001216313315545734021355 0ustar0000000000000000-- | Rectangular areas of levels and their basic operations. module Game.LambdaHack.Server.DungeonGen.Area ( Area, toArea, fromArea, trivialArea, isTrivialArea, mkFixed , SpecialArea(..), grid, shrink, expand, sumAreas ) where import Prelude () import Game.LambdaHack.Common.Prelude import Data.Binary import qualified Data.EnumMap.Strict as EM import qualified Data.IntSet as IS import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.Point import Game.LambdaHack.Content.PlaceKind (PlaceKind) -- | The type of areas. The bottom left and the top right points. data Area = Area X Y X Y deriving (Show, Eq) -- | Checks if it's an area with at least one field. toArea :: (X, Y, X, Y) -> Maybe Area toArea (x0, y0, x1, y1) = if x0 <= x1 && y0 <= y1 then Just $ Area x0 y0 x1 y1 else Nothing fromArea :: Area -> (X, Y, X, Y) fromArea (Area x0 y0 x1 y1) = (x0, y0, x1, y1) trivialArea :: Point -> Area trivialArea (Point x y) = Area x y x y isTrivialArea :: Area -> Bool isTrivialArea (Area x0 y0 x1 y1) = x0 == x1 && y0 == y1 -- Doesn't respect minimum sizes, because staircases are specified verbatim, -- so can't be arbitrarily scaled up. -- The size may be one more than what maximal size hint requests, -- but this is safe (limited by area size) and makes up for the rigidity -- of the fixed room sizes (e.g., that the size is always odd). mkFixed :: (X, Y) -- ^ maximum size -> Area -- ^ the containing area, not the room itself -> Point -- ^ the center point -> Area mkFixed (xMax, yMax) area p@Point{..} = let (x0, y0, x1, y1) = fromArea area xradius = min ((xMax + 1) `div` 2) $ min (px - x0) (x1 - px) yradius = min ((yMax + 1) `div` 2) $ min (py - y0) (y1 - py) a = (px - xradius, py - yradius, px + xradius, py + yradius) in fromMaybe (error $ "" `showFailure` (a, xMax, yMax, area, p)) $ toArea a data SpecialArea = SpecialArea Area | SpecialFixed Point (GroupName PlaceKind) Area | SpecialMerged SpecialArea Point deriving Show -- | Divide uniformly a larger area into the given number of smaller areas -- overlapping at the edges. -- -- When a list of fixed centers (some important points inside) -- of (non-overlapping) areas is given, incorporate those, -- with as little disruption, as possible. grid :: EM.EnumMap Point (GroupName PlaceKind) -> [Point] -> (X, Y) -> Area -> ((X, Y), EM.EnumMap Point SpecialArea) grid fixedCenters boot (nx, ny) (Area x0 y0 x1 y1) = let f z0 z1 n prev (c1 : c2 : rest) = let len = c2 - c1 + 1 cn = len * n `div` (z1 - z0 - 1) in if cn < 2 then let mid1 = (c1 + c2) `div` 2 mid2 = (c1 + c2) `divUp` 2 mid = if mid1 - prev > 4 then mid1 else mid2 in (prev, mid, Just c1) : f z0 z1 n mid (c2 : rest) else (prev, c1 + len `div` (2 * cn), Just c1) : [ ( c1 + len * (2 * z - 1) `div` (2 * cn) , c1 + len * (2 * z + 1) `div` (2 * cn) , Nothing ) | z <- [1 .. cn - 1] ] ++ f z0 z1 n (c1 + len * (2 * cn - 1) `div` (2 * cn)) (c2 : rest) f _ z1 _ prev [c1] = [(prev, z1, Just c1)] f _ _ _ _ [] = error $ "empty list of centers" `showFailure` fixedCenters xcs = IS.toList $ IS.fromList $ map px $ EM.keys fixedCenters ++ boot xallCenters = zip [0..] $ f x0 x1 nx x0 xcs ycs = IS.toList $ IS.fromList $ map py $ EM.keys fixedCenters ++ boot yallCenters = zip [0..] $ f y0 y1 ny y0 ycs in ( (length xallCenters, length yallCenters) , EM.fromDistinctAscList [ ( Point x y , case (mcx, mcy) of (Just cx, Just cy) -> case EM.lookup (Point cx cy) fixedCenters of Nothing -> SpecialArea area Just placeGroup -> SpecialFixed (Point cx cy) placeGroup area _ -> SpecialArea area ) | (y, (cy0, cy1, mcy)) <- yallCenters , (x, (cx0, cx1, mcx)) <- xallCenters , let area = Area cx0 cy0 cx1 cy1 ] ) -- | Shrink the given area on all fours sides by the amount. shrink :: Area -> Maybe Area shrink (Area x0 y0 x1 y1) = toArea (x0 + 1, y0 + 1, x1 - 1, y1 - 1) expand :: Area -> Area expand (Area x0 y0 x1 y1) = Area (x0 - 1) (y0 - 1) (x1 + 1) (y1 + 1) -- We assume the areas are adjacent. sumAreas :: Area -> Area -> Area sumAreas a@(Area x0 y0 x1 y1) a'@(Area x0' y0' x1' y1') = if | y1 == y0' -> assert (x0 == x0' && x1 == x1' `blame` (a, a')) $ Area x0 y0 x1 y1' | y0 == y1' -> assert (x0 == x0' && x1 == x1' `blame` (a, a')) $ Area x0' y0' x1' y1 | x1 == x0' -> assert (y0 == y0' && y1 == y1' `blame` (a, a')) $ Area x0 y0 x1' y1 | x0 == x1' -> assert (y0 == y0' && y1 == y1' `blame` (a, a')) $ Area x0' y0' x1 y1' | otherwise -> error $ "areas not adjacent" `showFailure` (a, a') 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.8.3.0/GameDefinition/0000755000000000000000000000000013315545734014711 5ustar0000000000000000LambdaHack-0.8.3.0/GameDefinition/PLAYING.md0000644000000000000000000003471713315545734016352 0ustar0000000000000000Playing LambdaHack ================== The following blurb is a copy of the game intro screen. LambdaHack is a small dungeon crawler illustrating the roguelike game engine of the same name. Playing the game involves exploring spooky dungeons, alone or in a party of fearless explorers, avoiding and setting up ambushes, hiding in shadows from the gaze of unspeakable horrors, discovering secret passages and gorgeous magical treasure and making creative use of it all. The madness-inspiring abominations that multiply in the depths perform the same feats, due to their aberrant, abstract hyper-intelligence, 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 modest sample game, but it has its own distinct quirky mood and is playable and winnable. Contributions are welcome. If the game window is too large for your screen or you experience other technical issues, please consult [README.md](https://github.com/LambdaHack/LambdaHack/blob/master/README.md) or describe your problem on gitter or the issue tracker. Heroes ------ The heroes are marked on the map with symbols `@` and `1` through `9`. The currently chosen party leader is highlighted on the map and his attributes are displayed at the bottommost status line, which in its most complex form looks as follows. *@12 4d1+5% Calm: 20/60 HP: 33/50 Target: basilisk [**__] The line starts with the list of party members, with the current leader highlighted. Most commands involve only the leader, including movement with keyboard's keypad or `LMB` (left mouse button). If more heroes are selected, e.g., by clicking on the list with `RMB` (right mouse button), they run together whenever `:` or `RMB` over map area is pressed. Next on the status line is the damage of the currently best melee weapon the leader can use, then his current and maximum Calm (morale, 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. Additionally, the colon after "Calm" turning into a dot signifies that the leader is in a position without ambient illumination and a brace sign instead of colon after "HP" means the leader is braced for combat (see section [Basic Commands](#basic-commands)). Instead of a monster, the target area may describe a position on the map, a recently spotted item on the floor or an item in inventory selected for further action or, if none are available, just display the current leader name. Weapon damage and other item stats are displayed using the dice notation `xdy`, which means `x` rolls of `y`-sided dice. A variant denoted `xdLy` is additionally scaled by the level depth in proportion to the maximal level depth (at the first level it's always one, then it grows up to full rolled value at the last level). Section [Monsters](#monsters) below describes combat resolution in detail, including the percentage damage bonus seen in the example. The second, upper 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` (aiming crosshair) is the common focus of the whole party, marked on the map and manipulated with mouse or movement keys in aiming mode. In this example, the corsshair points at an exact position on the map and at the end of the status line comes the length of the shortest path from the leader position to the spot and the straight-line distance between the two points. Game map -------- The map of any particular scenario may consist of one or many levels and each level consists of a large number of tiles. The game world is persistent, i.e., every time the player visits a level during a single game, its layout is the same. The basic tile kinds are as follows. game map terrain type on-screen symbol wall (horizontal and vertical) - and | tree or rock or man-made column O rubble & bush, transparent obstacle % trap, ice ^ closed door + open door (horizontal and vertical) | and - corridor # smoke or fog ; ground . stairs or exit up < stairs or exit down > bedrock blank So, for example, the following map shows a room with a closed door connected by a corridor with a room with an open door, a pillar, staircase down and rubble that obscures one of the corners. ---- ---- |..| |..&& |..+#######-.O.>&| |..| |.....| ---- ------- Basic Commands -------------- This section is a copy of the first two screens of in-game help and a screen introducing mouse commands. The help pages are automatically generated based on a game's keybinding content and on overrides in the player's config file. The remaining in-game help screens, not shown here, list all game commands grouped by categories, in detail. A text snapshot of the complete in-game help is in [InGameHelp.txt](InGameHelp.txt). Walk throughout a level with mouse or numeric keypad (left diagram below) or its compact laptop replacement (middle) or the Vi text editor keys (right, enabled in config.ui.ini). Run, until disturbed, by adding Shift or Control. Go-to with LMB (left mouse button). Run collectively with RMB. 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, the same keys (and mouse) move the x-hair (aiming crosshair). Press 'KP_5' ('5' on keypad, or 'i' or '.') to wait, bracing for impact, which reduces any damage taken and prevents displacement by foes. Press 'C-KP_5' (the same key with Control) to wait 0.1 of a turn, without bracing. You displace enemies by running into them with Shift/Control or RMB. Search, open, descend and attack by bumping into walls, doors, stairs and enemies. The best item to attack with is automatically chosen from among weapons in your personal equipment and your body parts. The following commands, joined with the basic set above, let you accomplish anything in the game, though not necessarily with the fewest keystrokes. You can also play the game exclusively with a mouse, or both mouse and keyboard. See the ending help screens for mouse commands. Lastly, you can select a command with arrows or mouse directly from the help screen or the dashboard and execute it on the spot. keys command g or , grab item(s) ESC cancel aiming/open main menu RET or INS accept target/open dashboard SPACE clear messages/display history S-TAB cycle among all party members KP_* or ! cycle x-hair among enemies C-c open or close or alter + swerve the aiming line Screen area and UI mode (aiming/exploration) determine mouse click effects. Here is an overview of effects of each button over most of the game map area. The list includes not only left and right buttons, but also the optional middle mouse button (MMB) and even the mouse wheel, which is normally used over menus, to page-scroll them. For mice without RMB, one can use C-LMB (Control key and left mouse button). keys command LMB set x-hair to enemy/go to pointer for 25 steps RMB or C-LMB fling at enemy/run to pointer collectively for 25 steps C-RMB open or close or alter at pointer MMB snap x-hair to floor under pointer WHEEL-UP swerve the aiming line WHEEL-DN unswerve the aiming line Advanced Commands ----------------- For ranged attacks, setting the aiming crosshair beforehand is not mandatory, because x-hair is set automatically as soon as a monster comes into view and can still be adjusted for as long as the missile to fling is not chosen. However, sometimes you want to examine the level map tile by tile or assign persistent personal targets to party members. The latter is essential in the rare cases when your henchmen (non-leader characters) can move autonomously or fire opportunistically (via innate skills or rare equipment). Also, if your henchman is adjacent to more than one enemy, setting his target makes him melee a particular foe. You can enter the detailed aiming mode with the `*` keypad key that selects enemies or the `/` keypad key that cycles among items on the floor and marks a tile underneath an item. You can move x-hair with direction keys and assign a personal target to the leader with `RET` key (Return, Enter). The details of the shared x-hair position and of the personal target are described in the status lines at the bottom of the screen, as explained in section [Heroes](#heroes) above. Commands for saving and exiting the current game, starting a new game, configuring convenience settings for the current game and challenges for the next game are listed in the main menu, brought up by the `ESC` key. Game difficulty, from the challenges menu, determines hitpoints at birth for any actor of any UI-using faction. The "lone wolf" challenge mode reduces player's starting actors to exactly one (consequently, this does not affect the initial 'raid' scenario). The "cold fish" challenge mode makes it impossible for player characters to be healed by actors from other factions (this is a significant restriction in the final 'crawl' scenario). For a person new to roguelikes, the 'raid' scenario offers a gentle introduction. The subsequent game scenarios gradually introduce squad combat, stealth, opportunity fire, asymmetric battles and more. Starting from the second scenario, the player controls a whole team of characters and will develop his repertoire of squad formations, preferred rendezvous locations and the use of light sources. The last scenario takes place in a multi-floor setting, giving player the choice of exploration of a single level at a time or portions of many levels along a single staircase and also of guarding staircases against enemies from other levels or, inversely, avoiding the staircases. Monsters -------- The life of the heroes is full of dangers. Monstrosities, natural and out of this world, roam the dark corridors and crawl from damp holes day and night. While heroes pay attention to all other party members and take care to move one at a time, monsters don't care about each other and all move at once, sometimes brutally colliding by accident. When a hero bumps into a monster or a monster attacks the hero, melee combat occurs. Heroes and monsters running into one another (with the `Shift` or `Control` 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. Since an item needs to be recharged in order to have its full effect, weapons on timeout are only considered according to their 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 a percentage bonus. The bonus is calculated by taking the damage bonus (summed from the equipped items of the attacker, capped at 200%) minus the melee armor modifier of the defender (capped at 200%, as well), with the outcome bounded between -99% and 99%, which means that at least 1% of damage always gets through and the damage is always lower than twice the dice roll. 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, with the usual dice and damage bonus. This time, the ranged armor stat of the defender is taken into account and, additionally, the speed of the missile (based on shape and weight) figures in the calculation. You may propel any item from your inventory (by default you are offered 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. In-game detailed item descriptions contain melee and ranged damage estimates. They do not take into account damage from effects and, if bonuses are not known, guesses are based on averages for the item kind in question. The displayed figures are rounded, but the game internally keeps track of minute fractions of HP. The stress of combat drains Calm, gradually limiting the use of items and, if Calm reaches zero and the actor is impressed by his foes, making him defect and surrender to their domination. Whenever the monster's or hero's hit points reach zero, the combatant is incapacitated and promptly dies. When the last hero dies or is dominated, the scenario ends in defeat. On Winning and Dying -------------------- You win a scenario if you escape the location alive (which may prove difficult, because your foes gradually build up the ambush squads blocking your escape routes) or, in scenarios with no exit locations, if you eliminate all opposition. In the former case, your score is based predominantly on the gold and precious gems you've plundered. In the latter case, your score is most influenced by the number of turns you spent overcoming your foes (the quicker the victory, the better; the slower the demise, the better). Bonus points, affected by the number of heroes lost, are awarded only if you win. The score is heavily modified by the chosen game difficulty, but not by any other challenges. When all your heroes fall, you are going to invariably see a new foolhardy party of adventurers clamoring to be led into the unknown. 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.8.3.0/GameDefinition/config.ui.default0000644000000000000000000000311513315545734020140 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] ; Angband compatibility (accept target) Cmd_2 = ("KP_Insert", ([CmdAim], "", ByAimMode {exploration = ExecuteIfClear Dashboard, aiming = Accept})) [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 at least) gtkFontFamily = "DejaVu Sans Mono,Consolas,Courier New,Liberation Mono,Courier,FreeMono,Monospace" ;sdlFontFile = "Fix15Mono-Bold.woff" fontSize = 16 sdlTtfSizeAdd = -2 sdlFontFile = "16x16x.fon" sdlFonSizeAdd = 1 ;sdlFontFile = "8x8x.fon" ;sdlFonSizeAdd = 2 colorIsBold = True ; New historyMax takes effect after removal of savefiles. historyMax = 5000 maxFps = 30 noAnim = False runStopMsgs = False hpWarningPercent = 20 overrideCmdline = "" LambdaHack-0.8.3.0/GameDefinition/InGameHelp.txt0000644000000000000000000001641313315545734017430 0ustar0000000000000000This is a snapshot of in-game help, rendered with default config file. For more general gameplay information see https://github.com/LambdaHack/LambdaHack/blob/master/GameDefinition/PLAYING.md Minimal cheat sheet for casual play (1/2). Walk throughout a level with mouse or numeric keypad (left diagram below) or its compact laptop replacement (middle) or the Vi text editor keys (right, enabled in config.ui.ini). Run, until disturbed, by adding Shift or Control. Go-to with LMB (left mouse button). Run collectively with RMB. 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, the same keys (and mouse) move the x-hair (aiming crosshair). Press 'KP_5' ('5' on keypad, or 'i' or '.') to wait, bracing for impact, which reduces any damage taken and prevents displacement by foes. Press 'C-KP_5' (the same key with Control) to wait 0.1 of a turn, without bracing. You displace enemies by running into them with Shift/Control or RMB. Search, open, descend and attack by bumping into walls, doors, stairs and enemies. The best item to attack with is automatically chosen from among weapons in your personal equipment and your body parts. Minimal cheat sheet for casual play (2/2). The following commands, joined with the basic set above, let you accomplish anything in the game, though not necessarily with the fewest keystrokes. You can also play the game exclusively with a mouse, or both mouse and keyboard. See the ending help screens for mouse commands. Lastly, you can select a command with arrows or mouse directly from the help screen or the dashboard and execute it on the spot. keys command g or , grab item(s) ESC cancel aiming/open main menu RET or INS accept target/open dashboard SPACE clear messages/display history S-TAB cycle among all party members KP_* or ! cycle x-hair among enemies C-c open or close or alter + swerve the aiming line Here is the complete list of commands from the snapshot of in-game help. For more general gameplay information see https://github.com/LambdaHack/LambdaHack/blob/master/GameDefinition/PLAYING.md All terrain exploration and alteration commands. keys command S-TAB cycle among all party members C-c open or close or alter TAB cycle among party members on the level c close door = select (or deselect) party member _ deselect (or select) all on the level ; go to x-hair for 25 steps : run to x-hair collectively for 25 steps x explore nearest unknown spot X autoexplore 25 times R rest (wait 25 times) C-R lurk (wait 0.1 turns 100 times) 0, 1 ... 6 pick a particular actor as the new leader Item menu commands. keys command g or , grab item(s) d or . drop item(s) f fling projectile C-f fling without aiming a apply consumable C-a apply and keep choice p pack item e equip item s stash and share item Remaining item-related commands. keys command ^ sort items by ownership, kind and stats P manage item pack of the leader G manage items on the ground E manage equipment of the leader S manage the shared party stash A manage all owned items @ describe organs of the leader # show stat summary of the leader ~ display known lore q quaff potion r read scroll t throw missile Aiming. keys command ESC cancel aiming/open main menu RET or INS accept target/open dashboard KP_* or ! cycle x-hair among enemies + swerve the aiming line KP_/ or / cycle x-hair among items - unswerve the aiming line \ cycle aiming modes C-? set x-hair to nearest unknown spot C-I set x-hair to nearest item C-{ set x-hair to nearest upstairs C-} set x-hair to nearest dnstairs < move aiming one level up > move aiming one level down BACKSPACE clear chosen item and target Assorted. keys command SPACE clear messages/display history F12 open dashboard ? or F1 display help v voice again the recorded commands V voice recorded commands 100 times C-v voice recorded commands 1000 times C-V voice recorded commands 25 times ' start recording commands C-P print screen Mouse overview. Screen area and UI mode (aiming/exploration) determine mouse click effects. Here is an overview of effects of each button over most of the game map area. The list includes not only left and right buttons, but also the optional middle mouse button (MMB) and even the mouse wheel, which is normally used over menus, to page-scroll them. For mice without RMB, one can use C-LMB (Control key and left mouse button). keys command LMB set x-hair to enemy/go to pointer for 25 steps RMB or C-LMB fling at enemy/run to pointer collectively for 25 steps C-RMB open or close or alter at pointer MMB snap x-hair to floor under pointer WHEEL-UP swerve the aiming line WHEEL-DN unswerve the aiming line Mouse in aiming mode. area LMB (left mouse button) RMB (right mouse button) message line clear messages/display history display help the map area set x-hair to enemy fling at enemy under pointer level number move aiming one level up move aiming one level down level caption accept target cancel aiming percent seen set x-hair to nearest upstairs set x-hair to nearest dnstairs x-hair info cycle x-hair among enemies cycle x-hair among items party roster pick new leader on screen select party member on screen Calm gauge rest (wait 25 times) lurk (wait 0.1 turns 100 times) HP gauge wait a turn, bracing for impact wait 0.1 of a turn target info fling without aiming clear chosen item and target Mouse in exploration mode. area LMB (left mouse button) RMB (right mouse button) message line clear messages/display history display help leader on map grab item(s) drop item(s) party on map pick new leader on screen select party member on screen the map area go to pointer for 25 steps run to pointer collectively level number move aiming one level up move aiming one level down level caption open dashboard open main menu percent seen explore nearest unknown spot autoexplore 25 times x-hair info cycle x-hair among enemies cycle x-hair among items party roster pick new leader on screen select party member on screen Calm gauge rest (wait 25 times) lurk (wait 0.1 turns 100 times) HP gauge wait a turn, bracing for impact wait 0.1 of a turn target info fling without aiming clear chosen item and target LambdaHack-0.8.3.0/GameDefinition/MainMenu.ascii0000644000000000000000000000707513315545734017445 0ustar0000000000000000 fffffjjjjtti,:Lft: tDEGLLGEKEK; . . . . .iEDEGL.;iiij ... fLLLLfffjjjti;.fL . GDDLfGDEDEf . . . . ;LDWEGi,;iit .. LD#WWELfffjjtt;.if.: .DEGLLGEDLti, . . . . . ,tLKDG ,;itt. fK#WWW#DLffjjtt;:;j... tDEGfLDEDGtK. . LambdaHack itLEG::;itt. ;K#WWWWW Lfffjjti:.t... tDEGfLDEDL, . tDGj.;itt. EWWWWKW GLffjjti: t, tDEGLGEEDj; tLDLi,ittj EKWWWEWG GLffjjti: tt .tDEGGDEDGi, ;fEG :iitj LEWWWKKK GLfffjti: tt tDDLGDEDGf. {{{{{{{{{{{{{{{{{{{{{{{{{{{{{{ ;jGG :iitj DWWWKDWL DLffjjti: jt.DDLGDEDLD {{{{{{{{{{{{{{{{{{{{{{{{{{{{{{ ,jDG .ittj LEWWWEDKj DLffjjti: jj.LGDEDLE {{{{{{{{{{{{{{{{{{{{{{{{{{{{{{ ,jDG ittj DKKWKDEKf GLffjjti::ff.EEDLE {{{{{{{{{{{{{{{{{{{{{{{{{{{{{{ ,fGG ittj GWKWEDEEt GLffjjji :fL.ELE {{{{{{{{{{{{{{{{{{{{{{{{{{{{{{ :tGL ittf EEWKKDGDEjt..DLfftjji.,fG:K, {{{{{{{{{{{{{{{{{{{{{{{{{{{{{{ ,fGj,.tjjf EfKGKDLGDDDGDGLffiiti ttf:. {{{{{{{{{{{{{{{{{{{{{{{{{{{{{{ .LG;i,;itt ..EDKEKEGjiLDDfGLLfijtii;fL: {{{{{{{{{{{{{{{{{{{{{{{{{{{{{{ jLj ,;tjtL . . KLEEKKDGLLLGLGLfffjji,;LL:,. {{{{{{{{{{{{{{{{{{{{{{{{{{{{{{,tfL.fijffL .......jDKEEKKKKKEDGLffffji;;LL:... {{{{{{{{{{{{{{{{{{{{{{{{{{{{{{j fGii tjff ..........KtGDKEDEEDGLGLfffjti,;Lf:::: {{{{{{{{{{{{{{{{{{{{{{{{{{{{{{iDf j:jffL. ..........::,E,tjjifL,,LLfffjji.;fL.,: {{{{{{{{{{{{{{{{{{{{{{{{{{{{{{fiififffL . ......::,;tjLGGGGGLfji;LLfffjjt.,jft. ;t;i:jfff . ..:::::,;;;,iiiiiiii;;;;LLfffjjt,,;LL: ... ,iiijjfffL .. ..:::::,,;;;;;;;;;;;;;;;;;GLffffjt;j,jff,:::, ;ifLjjijifffL .. .......::,,,,;;;;,,,,,,,,,:GLffffjjt:::tLiL LLLLGj;i,ffLLL ... . ..:::::,,,,,,,,,,, Version X.X.X (frontend: xxx, engine: LambdaHack X.X.X). LambdaHack-0.8.3.0/GameDefinition/Main.hs0000644000000000000000000000556313315545734016142 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 Prelude () import Game.LambdaHack.Common.Prelude import Control.Concurrent import Control.Concurrent.Async import qualified Control.Exception as Ex import qualified Options.Applicative as OA import System.Exit #ifndef USE_JSFILE import qualified GHC.IO.Handle import System.FilePath import qualified System.IO as SIO import Game.LambdaHack.Common.File (tryCreateDir) #endif import Game.LambdaHack.Common.Misc import Game.LambdaHack.Server (serverOptionsPI) import Implementation.TieKnot -- | Parse commandline options, tie the engine, content and clients knot, -- run the game and handle exit. main :: IO () main = do -- This may be broken with JS and also bloats the outcome file, so disabled. #ifndef USE_JSFILE -- Special case hack, when the game is started not on a console. -- Without this, any attempt to output on stdout crashes a Windows exe -- (at least on Windows Vista) launched from the desktop or start menu. -- This is very crude and results in the inability to, e.g., process -- the output of @--help@ through a unix pipe. However, this should be -- effective on all Windows version, without the need to test all. isTerminal <- SIO.hIsTerminalDevice SIO.stdout unless isTerminal $ do dataDir <- appDataDir tryCreateDir dataDir fstdout <- SIO.openFile (dataDir "stdout.txt") SIO.WriteMode fstderr <- SIO.openFile (dataDir "stderr.txt") SIO.WriteMode GHC.IO.Handle.hDuplicateTo fstdout SIO.stdout GHC.IO.Handle.hDuplicateTo fstderr SIO.stderr let fillWorkaround = -- Set up void workaround if nothing specific required. void $ tryPutMVar workaroundOnMainThreadMVar $ return () #endif -- Fail here, not inside server code, so that savefiles are not removed, -- because they are not the source of the failure. !serverOptions <- OA.execParser serverOptionsPI -- Avoid the bound thread that would slow down the communication. a <- async $ tieKnot serverOptions #ifndef USE_JSFILE `Ex.finally` fillWorkaround -- Run a (possibly void) workaround. It's needed for architectures/frontends -- that need to perform some actions on the main thread -- (not just any bound thread), e.g., newer OS X drawing with SDL2. workaround <- takeMVar workaroundOnMainThreadMVar workaround #endif resOrEx <- waitCatch a let unwrapEx e = #if MIN_VERSION_async(2,2,1) case Ex.fromException e of Just (ExceptionInLinkedThread _ ex) -> unwrapEx ex _ -> #endif e case resOrEx of Right () -> return () Left e -> case Ex.fromException $ unwrapEx e of Just ExitSuccess -> exitSuccess -- we are in the main thread, so here it really exits _ -> Ex.throwIO $ unwrapEx e LambdaHack-0.8.3.0/GameDefinition/Content/0000755000000000000000000000000013315545734016323 5ustar0000000000000000LambdaHack-0.8.3.0/GameDefinition/Content/ItemKindActor.hs0000644000000000000000000005060713315545734021364 0ustar0000000000000000-- | Actor (or rather actor body trunk) definitions. module Content.ItemKindActor ( actors ) where import Prelude () import Game.LambdaHack.Common.Prelude import Game.LambdaHack.Common.Ability import Game.LambdaHack.Common.Color import Game.LambdaHack.Common.Flavour import Game.LambdaHack.Common.ItemAspect (Aspect (..)) import Game.LambdaHack.Common.Misc import Game.LambdaHack.Content.ItemKind actors :: [ItemKind] actors = [warrior, warrior2, warrior3, warrior4, warrior5, scout, ranger, escapist, ambusher, soldier, civilian, civilian2, civilian3, civilian4, civilian5, eye, fastEye, nose, elbow, torsor, goldenJackal, griffonVulture, skunk, armadillo, gilaMonster, rattlesnake, komodoDragon, hyena, alligator, rhinoceros, beeSwarm, hornetSwarm, thornbush] -- LH-specific ++ [geyserBoiling, geyserArsenic, geyserSulfur] warrior, warrior2, warrior3, warrior4, warrior5, scout, ranger, escapist, ambusher, soldier, civilian, civilian2, civilian3, civilian4, civilian5, eye, fastEye, nose, elbow, torsor, goldenJackal, griffonVulture, skunk, armadillo, gilaMonster, rattlesnake, komodoDragon, hyena, alligator, rhinoceros, beeSwarm, hornetSwarm, thornbush :: ItemKind -- LH-specific geyserBoiling, geyserArsenic, geyserSulfur :: ItemKind -- * Hunams warrior = ItemKind { isymbol = '@' , iname = "warrior" -- modified if initial actors in hero faction , ifreq = [("hero", 100), ("mobile", 1)] , iflavour = zipPlain [BrWhite] , icount = 1 , irarity = [(1, 5)] , iverbHit = "thud" , iweight = 80000 , idamage = 0 , iaspects = [ AddMaxHP 80 -- partially from clothes and assumed first aid , AddMaxCalm 70, AddSpeed 20, AddNocto 2 , AddAbility AbProject 2, AddAbility AbApply 1 , AddAbility AbAlter 2 ] , ieffects = [] , ifeature = [Durable] , idesc = "" -- , idesc = "A hardened veteran of combat." , ikit = [ ("fist", COrgan), ("foot", COrgan), ("eye 6", COrgan) , ("sapient brain", COrgan) ] } warrior2 = warrior { iname = "adventurer" -- , idesc = "" } warrior3 = warrior { iname = "blacksmith" -- , idesc = "" } warrior4 = warrior { iname = "forester" -- , idesc = "" } warrior5 = warrior { iname = "scientist" -- , idesc = "" } scout = warrior { iname = "scout" , ifreq = [("scout hero", 100), ("mobile", 1)] , ikit = ikit warrior ++ [ ("add sight", CEqp) , ("armor ranged", CEqp) , ("add nocto 1", CInv) ] -- , idesc = "" } ranger = warrior { iname = "ranger" , ifreq = [("ranger hero", 100), ("mobile", 1)] , ikit = ikit warrior ++ [ ("armor ranged", CEqp) , ("weak arrow", CInv) ] -- , idesc = "" } escapist = warrior { iname = "escapist" , ifreq = [("escapist hero", 100), ("mobile", 1)] , ikit = ikit warrior ++ [ ("add sight", CEqp) , ("armor ranged", CEqp) , ("weak arrow", CInv) -- mostly for probing , ("light source", CInv) , ("wooden torch", CInv) , ("blanket", CInv) ] -- , idesc = "" } ambusher = warrior { iname = "ambusher" , ifreq = [("ambusher hero", 100), ("mobile", 1)] , ikit = ikit warrior -- dark and numerous, so more kit without exploring ++ [ ("ring of opportunity sniper", CEqp) , ("any arrow", CSha) , ("weak arrow", CInv) , ("explosive", CSha) , ("light source", CEqp) , ("wooden torch", CInv) ] -- , idesc = "" } soldier = warrior { iname = "soldier" , ifreq = [("soldier hero", 100), ("mobile", 1)] , ikit = ikit warrior ++ [ ("starting weapon", CEqp) , ("explosive", CSha) ] -- , idesc = "" } civilian = warrior { iname = "clerk" , ifreq = [("civilian", 100), ("mobile", 1)] , iflavour = zipPlain [BrBlack] -- , idesc = "" } civilian2 = civilian { iname = "hairdresser" -- , idesc = "" } civilian3 = civilian { iname = "lawyer" -- , idesc = "" } civilian4 = civilian { iname = "peddler" -- , idesc = "" } civilian5 = civilian { iname = "tax collector" -- , idesc = "" } -- * Monsters -- They have bright colours, because they are not natural. eye = ItemKind { isymbol = 'e' , iname = "reducible eye" , ifreq = [ ("monster", 100), ("mobile", 1) , ("mobile monster", 100), ("scout monster", 10) ] , iflavour = zipFancy [BrRed] , icount = 1 , irarity = [(1, 10), (10, 6)] , iverbHit = "thud" , iweight = 80000 , idamage = 0 , iaspects = [ AddMaxHP 16, AddMaxCalm 70, AddSpeed 20, AddNocto 2 , AddAggression 1 , AddAbility AbProject 2, AddAbility AbApply 1 , AddAbility AbAlter 2 ] , ieffects = [] , ifeature = [Durable] , 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), ("mobile", 1) , ("mobile monster", 100), ("scout monster", 60) ] , iflavour = zipFancy [BrBlue] , icount = 1 , irarity = [(5, 5), (10, 5)] , iverbHit = "thud" , iweight = 80000 , idamage = 0 , iaspects = [ AddMaxHP 5, AddMaxCalm 70, AddSpeed 30, AddNocto 2 , AddAggression 1 , AddAbility AbAlter 2 ] , ieffects = [] , ifeature = [Durable] , 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 6", COrgan) , ("sapient brain", COrgan) ] } nose = ItemKind -- depends solely on smell { isymbol = 'n' , iname = "point-free nose" , ifreq = [("monster", 100), ("mobile", 1), ("mobile monster", 100)] , iflavour = zipFancy [BrGreen] , icount = 1 , irarity = [(1, 5), (4, 2), (10, 5)] , iverbHit = "thud" , iweight = 80000 , idamage = 0 , iaspects = [ AddMaxHP 30, AddMaxCalm 30, AddSpeed 18, AddNocto 2 , AddAggression 1 , AddAbility AbProject (-1), AddAbility AbAlter 2 ] , ieffects = [] , ifeature = [Durable] , 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), ("mobile", 1) , ("mobile monster", 100), ("scout monster", 30) ] , iflavour = zipFancy [BrMagenta] , icount = 1 , irarity = [(7, 1), (10, 5)] , iverbHit = "thud" , iweight = 80000 , idamage = 0 , iaspects = [ AddMaxHP 8, AddMaxCalm 80, AddSpeed 21, AddNocto 2 , AddAbility AbProject 2, AddAbility AbApply 1 , AddAbility AbAlter 2, AddAbility AbMelee (-1) ] , ieffects = [] , ifeature = [Durable] , 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 16", COrgan) , ("any arrow", CSha), ("any arrow", CInv) , ("weak arrow", CInv), ("weak 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 , idamage = 0 , iaspects = [ AddMaxHP 300, AddMaxCalm 100, AddSpeed 10, AddNocto 2 , AddAggression 3, AddAbility AbProject 2, AddAbility AbApply 1 , AddAbility AbAlter 1] -- can't exit the gated level, the boss , ieffects = [] , ifeature = [Unique, Durable] , 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. -- They have dull colors, except for yellow, because there is no dull variant. goldenJackal = ItemKind -- basically a much smaller and slower hyena { isymbol = 'j' , iname = "golden jackal" , ifreq = [ ("animal", 100), ("mobile", 1), ("mobile animal", 100) , ("scavenger", 50) ] , iflavour = zipPlain [BrYellow] , icount = 1 , irarity = [(1, 3)] , iverbHit = "thud" , iweight = 13000 , idamage = 0 , iaspects = [ AddMaxHP 12, AddMaxCalm 70, AddSpeed 24, AddNocto 2 ] , ieffects = [] , ifeature = [Durable] , idesc = "An opportunistic predator, feeding on carrion and the weak." , ikit = [ ("small jaw", COrgan), ("eye 6", COrgan), ("nostril", COrgan) , ("animal brain", COrgan) ] } griffonVulture = ItemKind { isymbol = 'v' , iname = "griffon vulture" , ifreq = [ ("animal", 100), ("mobile", 1), ("mobile animal", 100) , ("scavenger", 30) ] , iflavour = zipPlain [BrYellow] , icount = 1 , irarity = [(1, 5)] , iverbHit = "thud" , iweight = 13000 , idamage = 0 , iaspects = [ AddMaxHP 12, AddMaxCalm 80, AddSpeed 22, AddNocto 2 , AddAbility AbAlter (-2) ] -- can't use stairs nor doors -- Animals don't have leader, usually, so even if only one of level, -- it pays the communication overhead, so the speed is higher to get -- them on par with human leaders moving solo. Random double moves, -- on either side, are just too frustrating. , ieffects = [] , ifeature = [Durable] , idesc = "It soars high above, searching for vulnerable prey." , ikit = [ ("screeching beak", COrgan) -- in reality it grunts and hisses , ("small claw", COrgan), ("eye 7", COrgan) , ("animal brain", COrgan) ] } skunk = ItemKind { isymbol = 's' , iname = "hog-nosed skunk" , ifreq = [("animal", 100), ("mobile", 1), ("mobile animal", 100)] , iflavour = zipPlain [White] , icount = 1 , irarity = [(1, 5), (10, 3)] , iverbHit = "thud" , iweight = 4000 , idamage = 0 , iaspects = [ AddMaxHP 10, AddMaxCalm 30, AddSpeed 22, AddNocto 2 , AddAbility AbAlter (-2) ] -- can't use stairs nor doors , ieffects = [] , ifeature = [Durable] , idesc = "Its only defence is the terrible stench." , ikit = [ ("scent gland", COrgan) , ("small claw", COrgan), ("snout", COrgan) , ("nostril", COrgan), ("eye 3", COrgan) , ("animal brain", COrgan) ] } armadillo = ItemKind { isymbol = 'a' , iname = "giant armadillo" , ifreq = [("animal", 100), ("mobile", 1), ("mobile animal", 100)] , iflavour = zipPlain [Brown] , icount = 1 , irarity = [(1, 5)] , iverbHit = "thud" , iweight = 80000 , idamage = 0 , iaspects = [ AddMaxHP 10, AddMaxCalm 30, AddSpeed 20, AddNocto 2 , AddAbility AbAlter (-2) ] -- can't use stairs nor doors , ieffects = [] , ifeature = [Durable] , idesc = "When threatened, it rolls into a ball." , ikit = [ ("hooked claw", COrgan), ("snout", COrgan) , ("armored skin", COrgan), ("armored skin", COrgan) , ("nostril", COrgan), ("eye 3", COrgan) , ("animal brain", COrgan) ] } gilaMonster = ItemKind { isymbol = 'g' , iname = "Gila monster" , ifreq = [("animal", 100), ("mobile", 1), ("mobile animal", 100)] , iflavour = zipPlain [Magenta] , icount = 1 , irarity = [(2, 5), (10, 3)] , iverbHit = "thud" , iweight = 80000 , idamage = 0 , iaspects = [ AddMaxHP 12, AddMaxCalm 50, AddSpeed 18, AddNocto 2 , AddAbility AbAlter (-2) ] -- can't use stairs nor doors , ieffects = [] , ifeature = [Durable] , idesc = "Numbing venom ensures that even the fastest prey has no escape." , ikit = [ ("venom tooth", COrgan), ("small claw", COrgan) , ("eye 3", COrgan), ("nostril", COrgan) , ("animal brain", COrgan) ] } rattlesnake = ItemKind { isymbol = 's' , iname = "rattlesnake" , ifreq = [("animal", 100), ("mobile", 1), ("mobile animal", 100)] , iflavour = zipPlain [Brown] , icount = 1 , irarity = [(5, 1), (10, 12)] , iverbHit = "thud" , iweight = 80000 , idamage = 0 , iaspects = [ AddMaxHP 25, AddMaxCalm 60, AddSpeed 16, AddNocto 2 , AddAbility AbAlter (-2) ] -- can't use stairs nor doors , ieffects = [] , ifeature = [Durable] , idesc = "Beware its rattle - it serves as a warning of an agonising death." , ikit = [ ("venom fang", COrgan) , ("eye 4", COrgan), ("nostril", COrgan) , ("animal brain", COrgan) ] } komodoDragon = ItemKind -- bad hearing; regeneration makes it very powerful { isymbol = 'k' , iname = "Komodo dragon" , ifreq = [("animal", 100), ("mobile", 1), ("mobile animal", 100)] , iflavour = zipPlain [Blue] , icount = 1 , irarity = [(9, 0), (10, 10)] , iverbHit = "thud" , iweight = 80000 , idamage = 0 , iaspects = [ AddMaxHP 41, AddMaxCalm 60, AddSpeed 18, AddNocto 2 ] , ieffects = [] , ifeature = [Durable] , idesc = "Larger and more aggressive than any other lizard." , ikit = [ ("large tail", COrgan), ("jaw", COrgan) , ("hooked claw", COrgan), ("speed gland 4", COrgan) , ("armored skin", COrgan), ("eye 3", COrgan) , ("nostril", COrgan), ("animal brain", COrgan) ] } hyena = ItemKind { isymbol = 'h' , iname = "spotted hyena" , ifreq = [ ("animal", 100), ("mobile", 1), ("mobile animal", 100) , ("scavenger", 20) ] , iflavour = zipPlain [BrYellow] , icount = 1 , irarity = [(4, 1), (10, 8)] , iverbHit = "thud" , iweight = 60000 , idamage = 0 , iaspects = [ AddMaxHP 20, AddMaxCalm 70, AddSpeed 32, AddNocto 2 ] , ieffects = [] , ifeature = [Durable] , idesc = "Skulking in the shadows, waiting for easy prey." , ikit = [ ("jaw", COrgan), ("eye 6", COrgan), ("nostril", COrgan) , ("animal brain", COrgan) ] } alligator = ItemKind { isymbol = 'a' , iname = "alligator" , ifreq = [("animal", 100), ("mobile", 1), ("mobile animal", 100)] , iflavour = zipPlain [Blue] , icount = 1 , irarity = [(8, 1), (10, 9)] , iverbHit = "thud" , iweight = 80000 , idamage = 0 , iaspects = [ AddMaxHP 41, AddMaxCalm 70, AddSpeed 18, AddNocto 2 ] , ieffects = [] , ifeature = [Durable] , idesc = "An armored predator from the dawn of time." , ikit = [ ("large jaw", COrgan), ("large tail", COrgan) , ("small claw", COrgan) , ("armored skin", COrgan), ("eye 6", 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 , idamage = 0 , iaspects = [ AddMaxHP 90, AddMaxCalm 60, AddSpeed 27, AddNocto 2 , AddAggression 2 , AddAbility AbAlter (-1) ] -- can't switch levels, a miniboss , ieffects = [] , ifeature = [Unique, Durable] , idesc = "The last of its kind. Blind with rage. Charges at deadly speed." , ikit = [ ("armored skin", COrgan), ("eye 2", COrgan) , ("rhino horn", COrgan), ("snout", COrgan) , ("animal brain", COrgan) ] } -- * Non-animal animals beeSwarm = ItemKind { isymbol = 'b' , iname = "bee swarm" , ifreq = [("animal", 100), ("mobile", 1)] , iflavour = zipPlain [Brown] , icount = 1 , irarity = [(1, 2), (10, 4)] , iverbHit = "thud" , iweight = 1000 , idamage = 0 , iaspects = [ AddMaxHP 8, AddMaxCalm 60 , AddSpeed 30, AddNocto 2 -- armor in sting , AddAbility AbAlter (-2) ] -- can't use stairs nor doors , ieffects = [] , ifeature = [Durable] , idesc = "Every bee would die for the queen." , ikit = [ ("bee sting", COrgan), ("vision 6", COrgan) , ("insect mortality", COrgan), ("animal brain", COrgan) ] } hornetSwarm = ItemKind { isymbol = 'h' , iname = "hornet swarm" , ifreq = [("animal", 100), ("mobile", 1), ("mobile animal", 100)] , iflavour = zipPlain [Magenta] , icount = 1 , irarity = [(5, 1), (10, 8)] , iverbHit = "thud" , iweight = 1000 , idamage = 0 , iaspects = [ AddMaxHP 8, AddMaxCalm 70, AddSpeed 30, AddNocto 2 , AddAbility AbAlter (-2) -- can't use stairs nor doors , AddArmorMelee 80, AddArmorRanged 40 ] , ieffects = [] , ifeature = [Durable] , idesc = "A vicious cloud of stings and hate." , ikit = [ ("sting", COrgan), ("vision 8", COrgan) , ("insect mortality", COrgan), ("animal brain", COrgan) ] } thornbush = ItemKind { isymbol = 't' , iname = "thornbush" , ifreq = [("animal", 18), ("immobile animal", 30)] , iflavour = zipPlain [Brown] , icount = 1 , irarity = [(1, 10)] , iverbHit = "thud" , iweight = 80000 , idamage = 0 , iaspects = [ AddMaxHP 20, AddMaxCalm 999, AddSpeed 22, AddNocto 2 , AddAbility AbWait 1, AddAbility AbMelee 1 ] , ieffects = [] , ifeature = [Durable] , idesc = "Each branch bears long, curved thorns." , ikit = [("thorn", COrgan), ("armored skin", COrgan)] } geyserBoiling = ItemKind { isymbol = 'g' , iname = "geyser" , ifreq = [("animal", 25), ("immobile animal", 60)] , iflavour = zipPlain [Blue] , icount = 1 , irarity = [(1, 3), (5, 3)] , iverbHit = "thud" , iweight = 80000 , idamage = 0 , iaspects = [ AddMaxHP 10, AddMaxCalm 999, AddSpeed 11, AddNocto 2 , AddAbility AbWait 1, AddAbility AbMelee 1 ] , ieffects = [] , ifeature = [Durable] , idesc = "A jet of acidic water, hot enough to melt flesh." , ikit = [("boiling vent", COrgan), ("boiling fissure", COrgan)] } geyserArsenic = ItemKind { isymbol = 'g' , iname = "arsenic geyser" , ifreq = [("animal", 8), ("immobile animal", 40)] , iflavour = zipPlain [Cyan] , icount = 1 , irarity = [(1, 10), (5, 10)] , iverbHit = "thud" , iweight = 80000 , idamage = 0 , iaspects = [ AddMaxHP 20, AddMaxCalm 999, AddSpeed 22 , AddNocto 2, AddShine 3 , AddAbility AbWait 1, AddAbility AbMelee 1 ] , ieffects = [] , ifeature = [Durable] , idesc = "The sharp scent betrays the poison within the spray." , ikit = [("arsenic vent", COrgan), ("arsenic fissure", COrgan)] } geyserSulfur = ItemKind { isymbol = 'g' , iname = "sulfur geyser" , ifreq = [("animal", 8), ("immobile animal", 120)] , iflavour = zipPlain [BrYellow] -- exception, animal with bright color , icount = 1 , irarity = [(1, 10), (5, 10)] , iverbHit = "thud" , iweight = 80000 , idamage = 0 , iaspects = [ AddMaxHP 20, AddMaxCalm 999, AddSpeed 22 , AddNocto 2, AddShine 3 , AddAbility AbWait 1, AddAbility AbMelee 1 ] , ieffects = [] , ifeature = [Durable] , idesc = "The pool boils and bubbles, stinking of rotten eggs. Despite the smell, these waters purify and strengthen." , ikit = [("sulfur vent", COrgan), ("sulfur fissure", COrgan)] } LambdaHack-0.8.3.0/GameDefinition/Content/ItemKindTemporary.hs0000644000000000000000000000667013315545734022277 0ustar0000000000000000-- | Temporary aspect pseudo-item definitions. module Content.ItemKindTemporary ( temporaries ) where import Prelude () import Game.LambdaHack.Common.Prelude import Game.LambdaHack.Common.Color import Game.LambdaHack.Common.Dice import Game.LambdaHack.Common.Flavour import Game.LambdaHack.Common.ItemAspect (Aspect (..)) import Game.LambdaHack.Common.Misc import Game.LambdaHack.Content.ItemKind temporaries :: [ItemKind] temporaries = [tmpStrengthened, tmpWeakened, tmpProtectedMelee, tmpProtectedRanged, tmpVulnerable, tmpResolute, tmpFast20, tmpSlow10, tmpFarSighted, tmpBlind, tmpKeenSmelling, tmpNoctovision, tmpDrunk, tmpRegenerating, tmpPoisoned, tmpSlow10Resistant, tmpPoisonResistant] tmpStrengthened, tmpWeakened, tmpProtectedMelee, tmpProtectedRanged, tmpVulnerable, tmpResolute, tmpFast20, tmpSlow10, tmpFarSighted, tmpBlind, tmpKeenSmelling, tmpNoctovision, 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. tmpAspects :: Text -> [Aspect] -> ItemKind tmpAspects name aspects = ItemKind { isymbol = '+' , iname = name , ifreq = [(toGroupName name, 1), ("condition", 1)] , iflavour = zipPlain [BrWhite] , icount = 1 , irarity = [(1, 1)] , iverbHit = "affect" , iweight = 0 , idamage = 0 , iaspects = -- timeout is 0; activates and vanishes soon, -- depending on initial timer setting aspects , ieffects = [ Recharging $ tmpLess name , OnSmash $ tmpLess name ] , ifeature = [Periodic, Fragile, Durable] -- hack: destroy on drop , idesc = "" -- no description needed; stats are enough , ikit = [] } tmpEffects :: Text -> Dice -> [Effect] -> ItemKind tmpEffects name icount effects = let tmp = tmpAspects name [] in tmp { icount , ieffects = effects ++ [ Recharging $ tmpNoLonger name , OnSmash $ tmpNoLonger name ] } tmpStrengthened = tmpAspects "strengthened" [AddHurtMelee 20] tmpWeakened = tmpAspects "weakened" [AddHurtMelee (-30)] -- don't cancel out ^ tmpProtectedMelee = tmpAspects "protected from melee" [AddArmorMelee 50] tmpProtectedRanged = tmpAspects "protected from ranged" [AddArmorRanged 25] tmpVulnerable = tmpAspects "defenseless" [ AddArmorMelee (-50) , AddArmorRanged (-25) ] tmpResolute = tmpAspects "resolute" [AddMaxCalm 60] tmpFast20 = tmpAspects "hasted" [AddSpeed 20] tmpSlow10 = tmpAspects "slowed" [AddSpeed (-10)] tmpFarSighted = tmpAspects "far-sighted" [AddSight 5] tmpBlind = tmpAspects "blind" [AddSight (-99)] tmpKeenSmelling = tmpAspects "keen-smelling" [AddSmell 2] tmpNoctovision = tmpAspects "shiny-eyed" [AddNocto 2] tmpDrunk = tmpAspects "drunk" [ AddHurtMelee 30 -- fury , AddArmorMelee (-20) , AddArmorRanged (-20) , AddSight (-8) ] tmpRegenerating = tmpEffects "regenerating" (4 + 1 `d` 2) [Recharging (RefillHP 1)] tmpPoisoned = tmpEffects "poisoned" (4 + 1 `d` 2) [Recharging (RefillHP (-1))] tmpSlow10Resistant = tmpEffects "slow resistant" (8 + 1 `d` 4) [Recharging (DropItem 1 1 COrgan "slowed")] tmpPoisonResistant = tmpEffects "poison resistant" (8 + 1 `d` 4) [Recharging (DropItem 1 maxBound COrgan "poisoned")] LambdaHack-0.8.3.0/GameDefinition/Content/CaveKind.hs0000644000000000000000000004135413315545734020352 0ustar0000000000000000-- | Cave properties. module Content.CaveKind ( content ) where import Prelude () import Game.LambdaHack.Common.Prelude import Data.Ratio import Game.LambdaHack.Common.Dice import Game.LambdaHack.Common.Misc import Game.LambdaHack.Content.CaveKind content :: [CaveKind] content = [rogue, arena, arena2, laboratory, empty, noise, noise2, shallow2rogue, shallow1rogue, raid, brawl, shootout, escape, zoo, ambush, battle, safari1, safari2, safari3] rogue, arena, arena2, laboratory, empty, noise, noise2, shallow2rogue, shallow1rogue, raid, brawl, shootout, escape, zoo, ambush, battle, safari1, safari2, safari3 :: CaveKind rogue = CaveKind { csymbol = 'R' , cname = "A maze of twisty passages" , cfreq = [ ("default random", 100), ("deep random", 100) , ("caveRogue", 1) ] , cxsize = fst normalLevelBound + 1 , cysize = snd normalLevelBound + 1 , cgrid = DiceXY (3 `d` 2) 4 , cminPlaceSize = DiceXY (2 `d` 2 + 4) 5 , cmaxPlaceSize = DiceXY 16 20 , cdarkChance = 1 `d` 54 + 1 `dL` 20 , cnightChance = 51 -- always night , cauxConnects = 1%2 , cmaxVoid = 1%6 , cminStairDist = 15 , cextraStairs = 1 + 1 `d` 2 , cdoorChance = 3%4 , copenChance = 1%5 , chidden = 7 , cactorCoeff = 65 -- the maze requires time to explore , cactorFreq = [("monster", 60), ("animal", 40)] , citemNum = 6 `d` 5 - 4 `dL` 1 -- deeper down quality over quantity , citemFreq = [("common item", 40), ("treasure", 60)] , cplaceFreq = [("rogue", 100)] , cpassable = False , cdefTile = "fillerWall" , cdarkCorTile = "floorCorridorDark" , clitCorTile = "floorCorridorLit" , cfillerTile = "fillerWall" , couterFenceTile = "basic outer fence" , clegendDarkTile = "legendDark" , clegendLitTile = "legendLit" , cescapeGroup = Nothing , cstairFreq = [("staircase", 100)] , cdesc = "Winding tunnels stretch into the dark." } -- no lit corridor alternative, because both lit # and . look bad here arena = rogue { csymbol = 'A' , cname = "Dusty underground library" , cfreq = [("default random", 40), ("caveArena", 1)] , cgrid = DiceXY (2 + 1 `d` 2) (1 + 1 `d` 2) , cminPlaceSize = DiceXY (2 `d` 2 + 4) 6 , cmaxPlaceSize = DiceXY 16 12 , cdarkChance = 49 + 1 `d` 10 -- almost all rooms dark (1 in 10 lit) -- Light is not too deadly, because not many obstructions and so -- foes visible from far away and few foes have ranged combat -- at shallow depth. , cnightChance = 0 -- always day , cauxConnects = 1 , cmaxVoid = 1%8 , cextraStairs = 1 , chidden = 0 , cactorCoeff = 50 , cactorFreq = [("monster", 30), ("animal", 70)] , citemNum = 4 `d` 5 -- few rooms , citemFreq = [("common item", 20), ("treasure", 40), ("any scroll", 40)] , cplaceFreq = [("arena", 100)] , cpassable = True , cdefTile = "arenaSetLit" , cdarkCorTile = "trailLit" -- let trails give off light , clitCorTile = "trailLit" , cdesc = "The shelves groan with dusty books and tattered scrolls." } arena2 = arena { cname = "Smoking rooms" , cfreq = [("deep random", 30)] , cdarkChance = 41 + 1 `d` 10 -- almost all rooms lit (1 in 10 dark) -- Trails provide enough light for fun stealth. , cnightChance = 51 -- always night , citemNum = 6 `d` 5 -- rare, so make it exciting , citemFreq = [("common item", 20), ("treasure", 40), ("any vial", 40)] , cdefTile = "arenaSetDark" , cdesc = "Velvet couches exude the strong smell of tobacco." } laboratory = arena2 { csymbol = 'L' , cname = "Burnt laboratory" , cfreq = [("deep random", 20), ("caveLaboratory", 1)] , cgrid = DiceXY (2 `d` 2 + 7) 3 , cminPlaceSize = DiceXY (3 `d` 2 + 4) 5 , cdarkChance = 1 `d` 54 + 1 `dL` 20 -- most rooms lit, to compensate for corridors , cnightChance = 0 -- always day , cauxConnects = 1%10 , cmaxVoid = 1%10 , cextraStairs = 1 , cdoorChance = 1 , copenChance = 1%2 , chidden = 7 , citemNum = 6 `d` 5 -- reward difficulty , citemFreq = [("common item", 20), ("treasure", 40), ("explosive", 40)] , cplaceFreq = [("laboratory", 100)] , cpassable = False , cdefTile = "fillerWall" , cdarkCorTile = "labTrailLit" -- let lab smoke give off light always , clitCorTile = "labTrailLit" , cdesc = "Shattered glassware and the sharp scent of spilt chemicals show that something terrible happened here." } empty = rogue { csymbol = 'E' , cname = "Tall cavern" , cfreq = [("caveEmpty", 1)] , cgrid = DiceXY 2 2 , cminPlaceSize = DiceXY 12 9 , cmaxPlaceSize = DiceXY 48 32 -- favour large rooms , cdarkChance = 1 `d` 100 + 1 `dL` 100 , cnightChance = 0 -- always day , cauxConnects = 3%2 , cminStairDist = 30 , cmaxVoid = 0 -- too few rooms to have void and fog common anyway , cextraStairs = 1 , cdoorChance = 0 , copenChance = 0 , chidden = 0 , cactorCoeff = 7 , cactorFreq = [("animal", 10), ("immobile animal", 90)] -- The healing geysers on lvl 3 act like HP resets. Needed to avoid -- cascading failure, if the particular starting conditions were -- very hard. Items are not reset, even if they are bad, which provides -- enough of a continuity. Gyesers on lvl 3 are not OP and can't be -- abused, because they spawn less and less often and also HP doesn't -- effectively accumulate over max. , citemNum = 4 `d` 5 -- few rooms and geysers are the boon , cplaceFreq = [("empty", 100)] , cpassable = True , cdefTile = "emptySet" , cdarkCorTile = "floorArenaDark" , clitCorTile = "floorArenaLit" , cdesc = "Swirls of warm fog fill the air, the hiss of geysers sounding all around." } noise = rogue { csymbol = 'N' , cname = "Leaky burrowed sediment" , cfreq = [("default random", 10), ("caveNoise", 1)] , cgrid = DiceXY (2 + 1 `d` 3) 3 , cminPlaceSize = DiceXY 8 6 , cmaxPlaceSize = DiceXY 20 10 , cdarkChance = 51 -- Light is deadly, because nowhere to hide and pillars enable spawning -- very close to heroes. , cnightChance = 0 -- harder variant, but looks cheerful , cauxConnects = 1%10 , cmaxVoid = 1%100 , cextraStairs = 1 + 1 `d` 2 , cdoorChance = 1 -- to avoid lit quasi-door tiles , chidden = 0 , cactorCoeff = 80 -- the maze requires time to explore , cactorFreq = [("monster", 80), ("animal", 20)] , citemNum = 6 `d` 5 -- an incentive to explore the labyrinth , cpassable = True , cplaceFreq = [("noise", 100)] , cdefTile = "noiseSet" , couterFenceTile = "noise fence" -- ensures no cut-off parts from collapsed , cdarkCorTile = "floorArenaDark" , clitCorTile = "floorArenaLit" , cdesc = "Soon, these passages will be swallowed up by the mud." } noise2 = noise { cname = "Frozen derelict mine" , cfreq = [("caveNoise2", 1)] , cnightChance = 51 -- easier variant, but looks sinister , citemNum = 11 `d` 5 -- an incentive to explore the final labyrinth , citemFreq = [ ("common item", 20), ("treasure", 60) , ("explosive", 20) ] , cplaceFreq = [("noise", 1), ("mine", 99)] , cstairFreq = [("gated staircase", 100)] , cdesc = "Pillars of shining ice create a frozen labyrinth." } shallow2rogue = rogue { cfreq = [("shallow random 2", 100)] , cextraStairs = 1 -- ensure heroes meet initial monsters and their loot , cdesc = "The snorts and grunts of savage beasts can be clearly heard." } shallow1rogue = shallow2rogue { csymbol = 'B' , cname = "Cave entrance" , cfreq = [("outermost", 100)] , cdarkChance = 0 -- all rooms lit, for a gentle start , cextraStairs = 1 , cactorFreq = filter ((/= "monster") . fst) $ cactorFreq rogue , citemNum = 8 `d` 5 -- lure them in with loot , citemFreq = filter ((/= "treasure") . fst) $ citemFreq rogue , cescapeGroup = Just "escape up" , cdesc = "This close to the surface, the sunlight still illuminates the dungeon." } raid = rogue { csymbol = 'T' , cname = "Typing den" , cfreq = [("caveRaid", 1)] , cdarkChance = 0 -- all rooms lit, for a gentle start , cmaxVoid = 1%10 , cactorCoeff = 250 -- deep level with no kit, so slow spawning , cactorFreq = [("animal", 100)] , citemNum = 6 `d` 8 -- just one level, hard enemies, treasure , citemFreq = [("common item", 100), ("currency", 500)] , cescapeGroup = Just "escape up" , cdesc = "" } brawl = rogue -- many random solid tiles, to break LOS, since it's a day -- and this scenario is not focused on ranged combat; -- also, sanctuaries against missiles in shadow under trees { csymbol = 'b' , cname = "Sunny woodland" , cfreq = [("caveBrawl", 1)] , cgrid = DiceXY (2 `d` 2 + 2) 3 , cminPlaceSize = DiceXY 3 3 , cmaxPlaceSize = DiceXY 7 5 , cdarkChance = 51 , cnightChance = 0 , cdoorChance = 1 , copenChance = 0 , cextraStairs = 1 , chidden = 0 , cactorFreq = [] , citemNum = 5 `d` 8 , citemFreq = [("common item", 100)] , cplaceFreq = [("brawl", 60), ("rogue", 40)] , cpassable = True , cdefTile = "brawlSetLit" , cdarkCorTile = "floorArenaLit" , clitCorTile = "floorArenaLit" , couterFenceTile = "outdoor outer fence" , cdesc = "Sunlight falls through the trees and dapples on the ground." } shootout = rogue -- a scenario with strong missiles; -- few solid tiles, but only translucent tiles or walkable -- opaque tiles, to make scouting and sniping more interesting -- and to avoid obstructing view too much, since this -- scenario is about ranged combat at long range { csymbol = 'S' , cname = "Misty meadow" , cfreq = [("caveShootout", 1)] , cgrid = DiceXY (1 `d` 2 + 7) 3 , cminPlaceSize = DiceXY 3 3 , cmaxPlaceSize = DiceXY 3 4 , cdarkChance = 51 , cnightChance = 0 , cdoorChance = 1 , copenChance = 0 , cextraStairs = 1 , chidden = 0 , cactorFreq = [] , citemNum = 5 `d` 16 -- less items in inventory, more to be picked up, -- to reward explorer and aggressor and punish camper , citemFreq = [ ("common item", 30) , ("any arrow", 400), ("harpoon", 300), ("explosive", 50) ] -- Many consumable buffs are needed in symmetric maps -- so that aggressor prepares them in advance and camper -- needs to waste initial turns to buff for the defence. , cplaceFreq = [("shootout", 100)] , cpassable = True , cdefTile = "shootoutSetLit" , cdarkCorTile = "floorArenaLit" , clitCorTile = "floorArenaLit" , couterFenceTile = "outdoor outer fence" , cdesc = "" } escape = rogue -- a scenario with weak missiles, because heroes don't depend -- on them; dark, so solid obstacles are to hide from missiles, -- not view; obstacles are not lit, to frustrate the AI; -- lots of small lights to cross, to have some risks { csymbol = 'E' , cname = "Metropolitan park at dusk" -- "night" didn't fit , cfreq = [("caveEscape", 1)] , cgrid = DiceXY -- (2 `d` 2 + 3) 4 -- park, so lamps in lines (2 `d` 2 + 6) 3 -- for now, to fit larger places , cminPlaceSize = DiceXY 3 3 , cmaxPlaceSize = DiceXY 9 9 -- bias towards larger lamp areas , cdarkChance = 51 -- colonnade rooms should always be dark , cnightChance = 51 -- always night , cauxConnects = 3%2 , cmaxVoid = 1%10 , cextraStairs = 1 , chidden = 0 , cactorFreq = [] , citemNum = 6 `d` 8 , citemFreq = [ ("common item", 30), ("gem", 150) , ("weak arrow", 500), ("harpoon", 400) , ("explosive", 100) ] , cplaceFreq = [("park", 100)] -- the same rooms as in ambush , cpassable = True , cdefTile = "escapeSetDark" -- different tiles, not burning yet , cdarkCorTile = "alarmingTrailLit" -- let trails give off light , clitCorTile = "alarmingTrailLit" , couterFenceTile = "outdoor outer fence" , cescapeGroup = Just "escape outdoor down" , cdesc = "" } zoo = rogue -- few lights and many solids, to help the less numerous heroes { csymbol = 'Z' , cname = "Menagerie in flames" , cfreq = [("caveZoo", 1)] , cgrid = DiceXY (2 `d` 2 + 6) 3 , cminPlaceSize = DiceXY 4 4 , cmaxPlaceSize = DiceXY 12 12 , cdarkChance = 51 -- always dark rooms , cnightChance = 51 -- always night , cauxConnects = 1%4 , cmaxVoid = 1%20 , cdoorChance = 7%10 , copenChance = 9%10 , cextraStairs = 1 , chidden = 0 , cactorFreq = [] , citemNum = 7 `d` 8 , citemFreq = [("common item", 100), ("light source", 1000)] , cplaceFreq = [("zoo", 50)] , cpassable = True , cdefTile = "zooSet" , cdarkCorTile = "trailLit" -- let trails give off light , clitCorTile = "trailLit" , couterFenceTile = "outdoor outer fence" , cdesc = "" } ambush = rogue -- a scenario with strong missiles; -- dark, so solid obstacles are to hide from missiles, -- not view, and they are all lit, because stopped missiles -- are frustrating, while a few LOS-only obstacles are not lit; -- lots of small lights to cross, to give a chance to snipe; -- a crucial difference wrt shootout is that trajectories -- of missiles are usually not seen, so enemy can't be guessed; -- camping doesn't pay off, because enemies can sneak and only -- active scouting, throwing flares and shooting discovers them { csymbol = 'M' , cname = "Burning metropolitan park" , cfreq = [("caveAmbush", 1)] , cgrid = DiceXY -- (2 `d` 2 + 3) 4 -- park, so lamps in lines (2 `d` 2 + 5) 3 -- for now, to fit larger places , cminPlaceSize = DiceXY 3 3 , cmaxPlaceSize = DiceXY 9 9 -- bias towards larger lamp areas , cdarkChance = 51 -- colonnade rooms should always be dark , cnightChance = 51 -- always night , cauxConnects = 3%2 , cmaxVoid = 1%20 , cextraStairs = 1 , chidden = 0 , cactorFreq = [] , citemNum = 5 `d` 8 , citemFreq = [ ("common item", 30) , ("any arrow", 400), ("harpoon", 300), ("explosive", 50) ] , cplaceFreq = [("park", 100)] , cpassable = True , cdefTile = "ambushSet" , cdarkCorTile = "trailLit" -- let trails give off light , clitCorTile = "trailLit" , couterFenceTile = "outdoor outer fence" , cdesc = "" } 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 , cauxConnects = 1%4 , cmaxVoid = 1%20 , cdoorChance = 2%10 , copenChance = 9%10 , cextraStairs = 1 , chidden = 0 , cactorFreq = [] , citemNum = 5 `d` 8 , citemFreq = [("common item", 100), ("light source", 200)] , cplaceFreq = [("battle", 50), ("rogue", 50)] , cpassable = True , cdefTile = "battleSet" , cdarkCorTile = "trailLit" -- let trails give off light , clitCorTile = "trailLit" , couterFenceTile = "outdoor outer fence" , cdesc = "" } safari1 = brawl { cname = "Hunam habitat" , cfreq = [("caveSafari1", 1)] , cstairFreq = [("staircase outdoor", 1)] , cdesc = "\"Act 1. Hunams scavenge in a forest in their usual disgusting way.\"" } safari2 = ambush -- lamps instead of trees, but ok, it's only a simulation { cname = "Deep into the jungle" , cfreq = [("caveSafari2", 1)] , cstairFreq = [("staircase outdoor", 1)] , cdesc = "\"Act 2. In the dark pure heart of the jungle noble animals roam freely.\"" } safari3 = zoo -- glass rooms, but ok, it's only a simulation { cname = "Jungle in flames" , cfreq = [("caveSafari3", 1)] , cescapeGroup = Just "escape outdoor down" , cstairFreq = [("staircase outdoor", 1)] , cdesc = "\"Act 3. Jealous hunams set jungle on fire and flee.\"" } LambdaHack-0.8.3.0/GameDefinition/Content/ModeKind.hs0000644000000000000000000004712113315545734020356 0ustar0000000000000000-- | Game mode definitions. module Content.ModeKind ( content ) where import Prelude () import Game.LambdaHack.Common.Prelude import qualified Data.IntMap.Strict as IM import Content.ModeKindPlayer import Game.LambdaHack.Common.Dice import Game.LambdaHack.Content.ModeKind content :: [ModeKind] content = [raid, brawl, shootout, escape, zoo, ambush, crawl, crawlEmpty, crawlSurvival, safari, safariSurvival, battle, battleSurvival, defense, defenseEmpty, screensaverRaid, screensaverBrawl, screensaverShootout, screensaverEscape, screensaverZoo, screensaverAmbush, screensaverCrawl, screensaverSafari] raid, brawl, shootout, escape, zoo, ambush, crawl, crawlEmpty, crawlSurvival, safari, safariSurvival, battle, battleSurvival, defense, defenseEmpty, screensaverRaid, screensaverBrawl, screensaverShootout, screensaverEscape, screensaverZoo, screensaverAmbush, screensaverCrawl, screensaverSafari :: ModeKind -- What other symmetric (two only-one-moves factions) and asymmetric vs crowd -- scenarios make sense (e.g., are good for a tutorial or for standalone -- extreme fun or are impossible as part of a crawl)? -- sparse melee at night: no, shade ambush in brawl is enough -- dense melee: no, keeping big party together is a chore and big enemy -- party is less fun than huge enemy party -- crowd melee in daylight: no, possible in crawl and at night is more fun -- sparse ranged at night: no, less fun than dense and if no reaction fire, -- just a camp fest or firing blindly -- dense ranged in daylight: no, less fun than at night with flares -- crowd ranged: no, fish in a barel, less predictable and more fun inside -- crawl, even without reaction fire raid = ModeKind -- mini-crawl { msymbol = 'r' , mname = "raid (1)" , mfreq = [("raid", 1), ("campaign scenario", 1)] , mroster = rosterRaid , mcaves = cavesRaid , mdesc = "An incredibly advanced typing machine worth 100 gold is buried at the exit of this maze. Be the first to find it and fund a research team that makes typing accurate and dependable forever." } brawl = ModeKind -- sparse melee in daylight, with shade for melee ambush { msymbol = 'k' , mname = "brawl (2)" , mfreq = [("brawl", 1), ("campaign scenario", 1)] , mroster = rosterBrawl , mcaves = cavesBrawl , mdesc = "Your engineering team disagrees over a drink with some gentlemen scientists about premises of a relative completeness theorem and there's only one way to settle that. Remember to keep your party together, or the opposing team might be tempted to gang upon a solitary disputant." } -- The trajectory tip is important because of tactics of scout looking from -- behind a bush and others hiding in mist. If no suitable bushes, -- fire once and flee into mist or behind cover. Then whomever is out of LOS -- range or inside mist can shoot at the last seen enemy locations, -- adjusting and according to ounds and incoming missile trajectories. -- If the scount can't find bushes or glass building to set a lookout, -- the other team member are more spotters and guardians than snipers -- and that's their only role, so a small party makes sense. shootout = ModeKind -- sparse ranged in daylight { msymbol = 's' , mname = "shootout (3)" , mfreq = [("shootout", 1), ("campaign scenario", 1)] , mroster = rosterShootout , mcaves = cavesShootout , mdesc = "Whose arguments are most striking and whose ideas fly fastest? Let's scatter up, attack the problems from different angles and find out. (To display the trajectory of any soaring entity, point it with the crosshair in aiming mode.)" } escape = ModeKind -- asymmetric ranged and stealth race at night { msymbol = 'e' , mname = "escape (4)" , mfreq = [("escape", 1), ("campaign scenario", 1)] , mroster = rosterEscape , mcaves = cavesEscape , mdesc = "Dwelling into dark matters is dangerous, so avoid the crowd of firebrand disputants, catch any gems of thought, find a way out and bring back a larger team to shed new light on the field." } zoo = ModeKind -- asymmetric crowd melee at night { msymbol = 'b' , mname = "zoo (5)" , mfreq = [("zoo", 1), ("campaign scenario", 1)] , mroster = rosterZoo , mcaves = cavesZoo , mdesc = "The heat of the dispute reaches the nearby Wonders of Science and Nature exhibition, igniting greenery, nets and cages. Crazed animals must be prevented from ruining precious scientific equipment and setting back the otherwise fruitful exchange of ideas." } -- The tactic is to sneak in the dark, highlight enemy with thrown torches -- (and douse thrown enemy torches with blankets) and only if this fails, -- actually scout using extended noctovision. -- With reaction fire, larger team is more fun. -- -- For now, while we have no shooters with timeout, massive ranged battles -- without reaction fire don't make sense, because then usually only one hero -- shoots (and often also scouts) and others just gather ammo. ambush = ModeKind -- dense ranged with reaction fire at night { msymbol = 'm' , mname = "ambush (6)" , mfreq = [("ambush", 1), ("campaign scenario", 1)] , mroster = rosterAmbush , mcaves = cavesAmbush , mdesc = "Prevent hijacking of your ideas at all cost! Be stealthy, be aggressive. Fast execution is what makes or breaks a creative team." } crawl = ModeKind { msymbol = 'c' , mname = "crawl (long)" , mfreq = [("crawl", 1), ("campaign scenario", 1)] , mroster = rosterCrawl , mcaves = cavesCrawl , mdesc = "Enjoy the peaceful seclusion of these cold austere tunnels, but don't let wanton curiosity, greed and the ever-creeping abstraction madness keep you down there for too long. If you find survivors (whole or perturbed or segmented) of the past scientific missions, exercise extreme caution and engage or ignore at your discretion." } safari = ModeKind -- easter egg available only via screensaver { msymbol = 'f' , mname = "safari" , mfreq = [("safari", 1)] , mroster = rosterSafari , mcaves = cavesSafari , mdesc = "\"In this enactment you'll discover the joys of hunting the most exquisite of Earth's flora and fauna, both animal and semi-intelligent. Exit at the bottommost level.\" This is a drama script recovered from a monster nest debris." } -- * Testing modes crawlEmpty = ModeKind { msymbol = 'c' , mname = "crawl empty" , mfreq = [("crawl empty", 1)] , mroster = rosterCrawlEmpty , mcaves = cavesCrawl , mdesc = "Enjoy the free space." } crawlSurvival = ModeKind { msymbol = 'd' , mname = "crawl survival" , mfreq = [("crawl survival", 1)] , mroster = rosterCrawlSurvival , mcaves = cavesCrawl , mdesc = "Lure the human intruders deeper and deeper." } safariSurvival = ModeKind { msymbol = 'u' , mname = "safari survival" , mfreq = [("safari survival", 1)] , mroster = rosterSafariSurvival , mcaves = cavesSafari , mdesc = "In this enactment you'll discover the joys of being hunted among the most exquisite of Earth's flora and fauna, both animal and semi-intelligent." } 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." } defense = ModeKind -- perhaps a real scenario in the future { msymbol = 'e' , mname = "defense" , mfreq = [("defense", 1)] , mroster = rosterDefense , mcaves = cavesCrawl , mdesc = "Don't let human interlopers defile your abstract secrets and flee unpunished!" } defenseEmpty = ModeKind { msymbol = 'e' , mname = "defense empty" , mfreq = [("defense empty", 1)] , mroster = rosterDefenseEmpty , mcaves = cavesCrawl , mdesc = "Lord over." } -- * Screensaver modes screensave :: AutoLeader -> Roster -> Roster screensave auto r = let f [] = [] f ((player, initial) : rest) = (player {fleaderMode = LeaderAI auto}, initial) : rest in r {rosterList = f $ rosterList r} screensaverRaid = raid { mname = "auto-raid (1)" , mfreq = [("starting", 1), ("starting JS", 1), ("no confirms", 1)] , mroster = screensave (AutoLeader False False) rosterRaid } screensaverBrawl = brawl { mname = "auto-brawl (2)" , mfreq = [("no confirms", 1)] , mroster = screensave (AutoLeader False False) rosterBrawl } screensaverShootout = shootout { mname = "auto-shootout (3)" , mfreq = [("starting", 1), ("starting JS", 1), ("no confirms", 1)] , mroster = screensave (AutoLeader False False) rosterShootout } screensaverEscape = escape { mname = "auto-escape (4)" , mfreq = [("starting", 1), ("starting JS", 1), ("no confirms", 1)] , mroster = screensave (AutoLeader False False) rosterEscape } screensaverZoo = zoo { mname = "auto-zoo (5)" , mfreq = [("no confirms", 1)] , mroster = screensave (AutoLeader False False) rosterZoo } screensaverAmbush = ambush { mname = "auto-ambush (6)" , mfreq = [("no confirms", 1)] , mroster = screensave (AutoLeader False False) rosterAmbush } screensaverCrawl = crawl { mname = "auto-crawl (long)" , mfreq = [("no confirms", 1)] , mroster = screensave (AutoLeader False False) rosterCrawl } screensaverSafari = safari { mname = "auto-safari" , mfreq = [("starting", 1), ("starting JS", 1), ("no confirms", 1)] , mroster = -- changing leader by client needed, because of TFollow screensave (AutoLeader False True) rosterSafari } rosterRaid, rosterBrawl, rosterShootout, rosterEscape, rosterZoo, rosterAmbush, rosterCrawl, rosterCrawlEmpty, rosterCrawlSurvival, rosterSafari, rosterSafariSurvival, rosterBattle, rosterBattleSurvival, rosterDefense, rosterDefenseEmpty :: Roster rosterRaid = Roster { rosterList = [ ( playerHero {fhiCondPoly = hiRaid} , [(-2, 1, "hero")] ) , ( playerAntiHero { fname = "Indigo Founder" , fhiCondPoly = hiRaid } , [(-2, 1, "hero")] ) , ( playerAnimal -- starting over escape , [(-2, 2, "animal")] ) , (playerHorror, []) ] -- for summoned monsters , rosterEnemy = [ ("Explorer", "Animal Kingdom") , ("Explorer", "Horror Den") , ("Indigo Founder", "Animal Kingdom") , ("Indigo Founder", "Horror Den") ] , rosterAlly = [] } rosterBrawl = Roster { rosterList = [ ( playerHero { fcanEscape = False , fhiCondPoly = hiDweller } , [(-3, 3, "hero")] ) , ( playerAntiHero { fname = "Indigo Researcher" , fcanEscape = False , fhiCondPoly = hiDweller } , [(-3, 3, "hero")] ) , (playerHorror, []) ] , rosterEnemy = [ ("Explorer", "Indigo Researcher") , ("Explorer", "Horror Den") , ("Indigo Researcher", "Horror Den") ] , rosterAlly = [] } -- Exactly one scout gets a sight boost, to help the aggressor, because he uses -- the scout for initial attack, while camper (on big enough maps) -- can't guess where the attack would come and so can't position his single -- scout to counter the stealthy advance. rosterShootout = Roster { rosterList = [ ( playerHero { fcanEscape = False , fhiCondPoly = hiDweller } , [(-5, 1, "scout hero"), (-5, 2, "ranger hero")] ) , ( playerAntiHero { fname = "Indigo Researcher" , fcanEscape = False , fhiCondPoly = hiDweller } , [(-5, 1, "scout hero"), (-5, 2, "ranger hero")] ) , (playerHorror, []) ] , rosterEnemy = [ ("Explorer", "Indigo Researcher") , ("Explorer", "Horror Den") , ("Indigo Researcher", "Horror Den") ] , rosterAlly = [] } rosterEscape = Roster { rosterList = [ ( playerHero {fhiCondPoly = hiEscapist} , [(-7, 1, "scout hero"), (-7, 2, "escapist hero")] ) , ( playerAntiHero { fname = "Indigo Researcher" , fcanEscape = False -- start on escape , fneverEmpty = False -- loot after killing , fhiCondPoly = hiDweller } , [(-7, 1, "scout hero"), (-7, 7, "ambusher hero")] ) , (playerHorror, []) ] , rosterEnemy = [ ("Explorer", "Indigo Researcher") , ("Explorer", "Horror Den") , ("Indigo Researcher", "Horror Den") ] , rosterAlly = [] } rosterZoo = Roster { rosterList = [ ( playerHero { fcanEscape = False , fhiCondPoly = hiDweller } , [(-8, 5, "soldier hero")] ) , ( playerAnimal {fneverEmpty = True} , [(-8, 100, "mobile animal")] ) , (playerHorror, []) ] -- for summoned monsters , rosterEnemy = [ ("Explorer", "Animal Kingdom") , ("Explorer", "Horror Den") ] , rosterAlly = [] } rosterAmbush = Roster { rosterList = [ ( playerHero { fcanEscape = False , fhiCondPoly = hiDweller } , [(-9, 1, "scout hero"), (-9, 5, "ambusher hero")] ) , ( playerAntiHero { fname = "Indigo Researcher" , fcanEscape = False , fhiCondPoly = hiDweller } , [(-9, 1, "scout hero"), (-9, 5, "ambusher hero")] ) , (playerHorror, []) ] , rosterEnemy = [ ("Explorer", "Indigo Researcher") , ("Explorer", "Horror Den") , ("Indigo Researcher", "Horror Den") ] , rosterAlly = [] } rosterCrawl = Roster { rosterList = [ ( playerHero , [(-1, 3, "hero")] ) , ( playerMonster , [(-4, 1, "scout monster"), (-4, 3, "monster")] ) , ( playerAnimal , -- Fun from the start to avoid empty initial level: [ (-1, 1 + 1 `d` 2, "animal") -- Huge battle at the end: , (-10, 100, "mobile animal") ] ) ] , rosterEnemy = [ ("Explorer", "Monster Hive") , ("Explorer", "Animal Kingdom") ] , rosterAlly = [("Monster Hive", "Animal Kingdom")] } rosterCrawlEmpty = Roster { rosterList = [ ( playerHero , [(-1, 1, "hero")] ) , (playerHorror, []) ] -- for summoned monsters , rosterEnemy = [] , rosterAlly = [] } rosterCrawlSurvival = rosterCrawl { rosterList = [ ( playerHero { fleaderMode = LeaderAI $ AutoLeader True False , fhasUI = False } , [(-1, 3, "hero")] ) , ( playerMonster , [(-4, 1, "scout monster"), (-4, 3, "monster")] ) , ( playerAnimal {fhasUI = True} , -- Fun from the start to avoid empty initial level: [ (-1, 1 + 1 `d` 2, "animal") -- Huge battle at the end: , (-10, 100, "mobile animal") ] ) ] } -- No horrors faction needed, because spawned heroes land in civilian faction. rosterSafari = Roster { rosterList = [ ( playerMonsterTourist , [(-4, 15, "monster")] ) , ( playerHunamConvict , [(-4, 3, "civilian")] ) , ( playerAnimalMagnificent , [(-7, 20, "mobile animal")] ) , ( playerAnimalExquisite -- start on escape , [(-10, 30, "mobile animal")] ) ] , rosterEnemy = [ ("Monster Tourist Office", "Hunam Convict") , ( "Monster Tourist Office" , "Animal Magnificent Specimen Variety" ) , ( "Monster Tourist Office" , "Animal Exquisite Herds and Packs Galore" ) , ( "Animal Magnificent Specimen Variety" , "Hunam Convict" ) , ( "Hunam Convict" , "Animal Exquisite Herds and Packs Galore" ) ] , rosterAlly = [ ( "Animal Magnificent Specimen Variety" , "Animal Exquisite Herds and Packs Galore" ) ] } rosterSafariSurvival = rosterSafari { rosterList = [ ( playerMonsterTourist { fleaderMode = LeaderAI $ AutoLeader True True , fhasUI = False } , [(-4, 15, "monster")] ) , ( playerHunamConvict , [(-4, 3, "civilian")] ) , ( playerAnimalMagnificent { fleaderMode = LeaderUI $ AutoLeader True False , fhasUI = True } , [(-7, 20, "mobile animal")] ) , ( playerAnimalExquisite , [(-10, 30, "mobile animal")] ) ] } rosterBattle = Roster { rosterList = [ ( playerHero { fcanEscape = False , fhiCondPoly = hiDweller } , [(-5, 5, "soldier hero")] ) , ( playerMonster {fneverEmpty = True} , [(-5, 35, "mobile monster")] ) , ( playerAnimal {fneverEmpty = True} , [(-5, 30, "mobile animal")] ) ] , rosterEnemy = [ ("Explorer", "Monster Hive") , ("Explorer", "Animal Kingdom") ] , rosterAlly = [("Monster Hive", "Animal Kingdom")] } rosterBattleSurvival = rosterBattle { rosterList = [ ( playerHero { fcanEscape = False , fhiCondPoly = hiDweller , fleaderMode = LeaderAI $ AutoLeader False False , fhasUI = False } , [(-5, 5, "soldier hero")] ) , ( playerMonster {fneverEmpty = True} , [(-5, 35, "mobile monster")] ) , ( playerAnimal { fneverEmpty = True , fhasUI = True } , [(-5, 30, "mobile animal")] ) ] } rosterDefense = rosterCrawl { rosterList = [ ( playerAntiHero , [(-1, 3, "hero")] ) , ( playerAntiMonster , [(-4, 1, "scout monster"), (-4, 3, "monster")] ) , ( playerAnimal , [ (-1, 1 + 1 `d` 2, "animal") , (-10, 100, "mobile animal") ] ) ] } rosterDefenseEmpty = rosterCrawl { rosterList = [ ( playerAntiMonster {fneverEmpty = True} , [(-4, 1, "scout monster")] ) , (playerHorror, []) ] -- for summoned animals , rosterEnemy = [] , rosterAlly = [] } cavesRaid, cavesBrawl, cavesShootout, cavesEscape, cavesZoo, cavesAmbush, cavesCrawl, cavesSafari, cavesBattle :: Caves cavesRaid = IM.fromList [(-2, "caveRaid")] cavesBrawl = IM.fromList [(-3, "caveBrawl")] cavesShootout = IM.fromList [(-5, "caveShootout")] cavesEscape = IM.fromList [(-7, "caveEscape")] cavesZoo = IM.fromList [(-8, "caveZoo")] cavesAmbush = IM.fromList [(-9, "caveAmbush")] cavesCrawl = IM.fromList $ [ (-1, "outermost") , (-2, "shallow random 2") , (-3, "caveEmpty") ] ++ zip [-4, -5] (repeat "default random") ++ zip [-6, -7, -8, -9] (repeat "deep random") ++ [(-10, "caveNoise2")] cavesSafari = IM.fromList [ (-4, "caveSafari1") , (-7, "caveSafari2") , (-10, "caveSafari3") ] cavesBattle = IM.fromList [(-5, "caveBattle")] LambdaHack-0.8.3.0/GameDefinition/Content/ItemKindBlast.hs0000644000000000000000000005435713315545734021367 0ustar0000000000000000-- | Blast definitions. module Content.ItemKindBlast ( blasts ) where import Prelude () import Game.LambdaHack.Common.Prelude import Game.LambdaHack.Common.Color import Game.LambdaHack.Common.Dice import Game.LambdaHack.Common.Flavour import Game.LambdaHack.Common.ItemAspect (Aspect (..)) import Game.LambdaHack.Common.Misc import Game.LambdaHack.Content.ItemKind blasts :: [ItemKind] blasts = [burningOil2, burningOil3, burningOil4, firecracker1, firecracker2, firecracker3, firecracker4, firecracker5, spreadFragmentation, spreadFragmentation8, focusedFragmentation, spreadConcussion, spreadConcussion8, focusedConcussion, spreadFlash, spreadFlash8, focusedFlash, singleSpark, glassPiece, focusedGlass,fragrance, pheromone, mistCalming, odorDistressing, mistHealing, mistHealing2, mistWounding, distortion, smoke, boilingWater, glue, waste, denseShower, sparseShower, protectingBalmMelee, protectingBalmRanged, vulnerabilityBalm, resolutionDust, hasteSpray, slownessMist, eyeDrop, ironFiling, smellyDroplet, eyeShine, whiskeySpray, youthSprinkle, poisonCloud, mistAntiSlow, mistAntidote] burningOil2, burningOil3, burningOil4, firecracker1, firecracker2, firecracker3, firecracker4, firecracker5, spreadFragmentation, spreadFragmentation8, focusedFragmentation, spreadConcussion, spreadConcussion8, focusedConcussion, spreadFlash, spreadFlash8, focusedFlash, singleSpark, glassPiece, focusedGlass,fragrance, pheromone, mistCalming, odorDistressing, mistHealing, mistHealing2, mistWounding, distortion, smoke, boilingWater, glue, waste, denseShower, sparseShower, protectingBalmMelee, protectingBalmRanged, vulnerabilityBalm, resolutionDust, hasteSpray, slownessMist, eyeDrop, ironFiling, smellyDroplet, eyeShine, whiskeySpray, youthSprinkle, poisonCloud, mistAntiSlow, mistAntidote :: ItemKind -- We take care (e.g., in burningOil below) that blasts are not faster -- than 100% fastest natural speed, or some frames would be skipped, -- which is a waste of prefectly good frames. -- * Parameterized blasts burningOil :: Int -> ItemKind burningOil n = ItemKind { isymbol = '*' , iname = "burning oil" , ifreq = [(toGroupName $ "burning oil" <+> tshow n, 1)] , iflavour = zipPlain [BrYellow] , icount = intToDice (n * 8) , irarity = [(1, 1)] , iverbHit = "sear" , iweight = 1 , idamage = 0 , iaspects = [AddShine 2] , ieffects = [ Burn 1 , toOrganBad "slowed" (2 + 1 `d` 2) ] -- tripping on oil , ifeature = [ toVelocity (min 100 $ n `div` 2 * 10) , Fragile, Blast ] , idesc = "Sticky oil, burning brightly." , ikit = [] } burningOil2 = burningOil 2 -- 2 steps, 2 turns burningOil3 = burningOil 3 -- 3 steps, 2 turns burningOil4 = burningOil 4 -- 4 steps, 2 turns firecracker :: Int -> ItemKind firecracker n = ItemKind { isymbol = '*' , iname = "firecracker" , ifreq = [(toGroupName $ if n == 5 then "firecracker" else "firecracker" <+> tshow n, 1)] , iflavour = zipPlain [brightCol !! ((n + 2) `mod` length brightCol)] , icount = if n <= 3 then 1 `d` min 2 n else 2 + 1 `d` 2 , irarity = [(1, 1)] , iverbHit = if n >= 4 then "singe" else "crack" , iweight = 1 , idamage = 0 , iaspects = [AddShine $ intToDice $ 1 + n `div` 2] , ieffects = [if n >= 4 then Burn 1 else RefillCalm (-2)] ++ [DropBestWeapon | n >= 4] ++ [ OnSmash $ Explode $ toGroupName $ "firecracker" <+> tshow (n - 1) | n >= 2 ] , ifeature = [toVelocity 5, Fragile, Blast] , idesc = "Scraps of burnt paper, covering little pockets of black powder, buffeted by colorful explosions." , ikit = [] } firecracker5 = firecracker 5 firecracker4 = firecracker 4 firecracker3 = firecracker 3 firecracker2 = firecracker 2 firecracker1 = firecracker 1 -- * Focused blasts spreadFragmentation = ItemKind { isymbol = '*' , iname = "fragmentation burst" , ifreq = [("violent fragmentation", 1)] , iflavour = zipPlain [Red] -- flying shards; some fire and smoke , icount = 16 -- strong but few, so not always hits target , irarity = [(1, 1)] , iverbHit = "tear apart" , iweight = 1 , idamage = 3 `d` 1 -- deadly and adjacent actor hit by 2 on average; -- however, moderate armour blocks completely , iaspects = [AddShine 3, AddHurtMelee $ -12 * 5] , ieffects = [DropItem 1 maxBound COrgan "condition"] , ifeature = [toLinger 20, Lobable, Fragile, Blast] -- 4 steps, 1 turn , idesc = "" , ikit = [] } spreadFragmentation8 = spreadFragmentation { iname = "fragmentation burst" , ifreq = [("fragmentation", 1)] , icount = 8 , ifeature = [toLinger 10, Lobable, Fragile, Blast] -- 2 steps, 1 turn -- smaller radius, so worse for area effect, but twice the direct damage } focusedFragmentation = ItemKind { isymbol = '`' , iname = "deflagration ignition" -- black powder , ifreq = [("focused fragmentation", 1)] , iflavour = zipPlain [BrYellow] , icount = 4 -- 32 in total vs 16; on average 4 hits , irarity = [(1, 1)] , iverbHit = "ignite" , iweight = 1 , idamage = 0 , iaspects = [] , ieffects = [OnSmash $ Explode "fragmentation"] , ifeature = [toLinger 0, Fragile, Blast] -- 0 steps, 1 turn -- when the target position is occupied, the explosion starts one step -- away, hence we set range to 0 steps, to limit dispersal , idesc = "" , ikit = [] } spreadConcussion = ItemKind { isymbol = '*' , iname = "concussion blast" , ifreq = [("violent concussion", 1)] , iflavour = zipPlain [Magenta] -- mosty shock wave; some fire and smoke , icount = 16 , irarity = [(1, 1)] , iverbHit = "shock" , iweight = 1 , idamage = 1 `d` 1 -- only air pressure, so not as deadly as fragmentation, -- but armour can't block completely that easily , iaspects = [AddShine 3, AddHurtMelee $ -8 * 5] , ieffects = [ DropItem maxBound 1 CEqp "misc armor" , PushActor (ThrowMod 400 25) -- 1 step, fast; after DropItem -- this produces spam for braced actors; too bad , DropItem 1 maxBound COrgan "condition" ] , ifeature = [toLinger 20, Lobable, Fragile, Blast] -- 4 steps, 1 turn -- outdoors it has short range, but we only model indoors in the game; -- it's much faster than black powder shock wave, but we are beyond -- human-noticeable speed differences on short distances anyway , idesc = "" , ikit = [] } spreadConcussion8 = spreadConcussion { iname = "concussion blast" , ifreq = [("concussion", 1)] , icount = 8 , ifeature = [toLinger 10, Lobable, Fragile, Blast] -- 2 steps, 1 turn } focusedConcussion = ItemKind { isymbol = '`' , iname = "detonation ignition" -- nitroglycerine , ifreq = [("focused concussion", 1)] , iflavour = zipPlain [BrYellow] , icount = 4 , irarity = [(1, 1)] , iverbHit = "ignite" , iweight = 1 , idamage = 0 , iaspects = [] , ieffects = [OnSmash $ Explode "concussion"] , ifeature = [toLinger 0, Fragile, Blast] -- 0 steps, 1 turn , idesc = "" , ikit = [] } spreadFlash = ItemKind { isymbol = '`' , iname = "magnesium flash" , ifreq = [("violent flash", 1)] , iflavour = zipPlain [BrWhite] -- very brigh flash , icount = 16 , irarity = [(1, 1)] , iverbHit = "dazzle" , iweight = 1 , idamage = 0 , iaspects = [AddShine 5] , ieffects = [toOrganBad "blind" 10, toOrganBad "weakened" 30] -- Wikipedia says: blind for five seconds and afterimage -- for much longer, harming aim , ifeature = [toLinger 20, Fragile, Blast] -- 4 steps, 1 turn , idesc = "A flash of fire." , ikit = [] } spreadFlash8 = spreadFlash { iname = "spark" , ifreq = [("spark", 1)] , icount = 8 , iverbHit = "blind" , ifeature = [toLinger 10, Fragile, Blast] -- 2 steps, 1 turn } focusedFlash = ItemKind { isymbol = '`' , iname = "magnesium ignition" , ifreq = [("focused flash", 1)] , iflavour = zipPlain [BrYellow] , icount = 4 , irarity = [(1, 1)] , iverbHit = "ignite" , iweight = 1 , idamage = 0 , iaspects = [] , ieffects = [OnSmash $ Explode "spark"] , ifeature = [toLinger 0, Fragile, Blast] -- 0 steps, 1 turn , idesc = "" , ikit = [] } singleSpark = spreadFlash { iname = "single spark" , ifreq = [("single spark", 1)] , icount = 1 , iverbHit = "spark" , iaspects = [AddShine 3] , ieffects = [] , ifeature = [toLinger 5, Fragile, Blast] -- 1 step, 1 turn , idesc = "A glowing ember." , ikit = [] } glassPiece = ItemKind { isymbol = '*' , iname = "glass piece" , ifreq = [("glass hail", 1)] , iflavour = zipPlain [Blue] , icount = 8 , irarity = [(1, 1)] , iverbHit = "cut" , iweight = 1 , idamage = 1 `d` 1 , iaspects = [AddHurtMelee $ -15 * 5] -- brittle, not too dense; armor blocks , ieffects = [RefillHP (-1)] , ifeature = [toLinger 20, Fragile, Blast] -- 4 steps, 1 turn , idesc = "Swift, sharp edges." , ikit = [] } focusedGlass = glassPiece -- when blowing up windows { ifreq = [("focused glass hail", 1)] , icount = 4 , ieffects = [RefillHP (-1), OnSmash $ Explode "glass hail"] , ifeature = [toLinger 0, Fragile, Blast] -- 0 steps, 1 turn } -- * Assorted immediate effect blasts fragrance = ItemKind { isymbol = '`' , iname = "fragrance" -- instant, fast fragrance , ifreq = [("fragrance", 1)] , iflavour = zipPlain [Magenta] , icount = 12 , irarity = [(1, 1)] , iverbHit = "engulf" , iweight = 1 , idamage = 0 , 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 = [toLinger 10, Fragile, Blast] -- 2 steps, 1 turn , idesc = "A pleasant scent." , ikit = [] } pheromone = ItemKind { isymbol = '`' , iname = "musky whiff" -- a kind of mist rather than fragrance , ifreq = [("pheromone", 1)] , iflavour = zipPlain [BrMagenta] , icount = 16 , irarity = [(1, 1)] , iverbHit = "tempt" , iweight = 1 , idamage = 0 , iaspects = [] , ieffects = [Impress, RefillCalm (-10)] , ifeature = [toVelocity 10, Fragile, Blast] -- 2 steps, 2 turns , idesc = "A sharp, strong scent." , ikit = [] } mistCalming = ItemKind -- unused { isymbol = '`' , iname = "mist" , ifreq = [("calming mist", 1)] , iflavour = zipPlain [BrGreen] , icount = 8 , irarity = [(1, 1)] , iverbHit = "sooth" , iweight = 1 , idamage = 0 , iaspects = [] , ieffects = [RefillCalm 2] , ifeature = [toVelocity 5, Fragile, Blast] -- 1 step, 1 turn , idesc = "A soothing, gentle cloud." , ikit = [] } odorDistressing = ItemKind { isymbol = '`' , iname = "distressing whiff" , ifreq = [("distressing odor", 1)] , iflavour = zipFancy [BrRed] -- salmon , icount = 8 , irarity = [(1, 1)] , iverbHit = "distress" , iweight = 1 , idamage = 0 , iaspects = [] , ieffects = [RefillCalm (-20)] , ifeature = [toLinger 10, Fragile, Blast] -- 2 steps, 1 turn , idesc = "It turns the stomach." , ikit = [] } mistHealing = ItemKind { isymbol = '`' , iname = "mist" -- powerful, so slow and narrow , ifreq = [("healing mist", 1)] , iflavour = zipFancy [BrGreen] , icount = 8 , irarity = [(1, 1)] , iverbHit = "revitalize" , iweight = 1 , idamage = 0 , iaspects = [AddShine 1] , ieffects = [RefillHP 2] , ifeature = [toVelocity 5, Fragile, Blast] -- 1 step, 1 turn , idesc = "It fills the air with light and life." , ikit = [] } mistHealing2 = ItemKind { isymbol = '`' , iname = "mist" , ifreq = [("healing mist 2", 1)] , iflavour = zipPlain [Green] , icount = 8 , irarity = [(1, 1)] , iverbHit = "revitalize" , iweight = 1 , idamage = 0 , iaspects = [AddShine 2] , ieffects = [RefillHP 4] , ifeature = [toVelocity 5, Fragile, Blast] -- 1 step, 1 turn , idesc = "At its touch, wounds close and bruises fade." , ikit = [] } mistWounding = ItemKind { isymbol = '`' , iname = "mist" , ifreq = [("wounding mist", 1)] , iflavour = zipPlain [BrRed] , icount = 8 , irarity = [(1, 1)] , iverbHit = "devitalize" , iweight = 1 , idamage = 0 , iaspects = [] , ieffects = [RefillHP (-2)] , ifeature = [toVelocity 5, Fragile, Blast] -- 1 step, 1 turn , idesc = "The air itself stings and itches." , ikit = [] } distortion = ItemKind { isymbol = 'v' , iname = "vortex" , ifreq = [("distortion", 1)] , iflavour = zipPlain [White] , icount = 8 -- braced are immune to Teleport; avoid failure messages , irarity = [(1, 1)] , iverbHit = "engulf" , iweight = 1 , idamage = 0 , iaspects = [] , ieffects = [Teleport $ 15 + 1 `d` 10] , ifeature = [toLinger 10, Lobable, Fragile, Blast] -- 2 steps, 1 turn , idesc = "The air shifts oddly, as though light is being warped." , ikit = [] } smoke = ItemKind -- when stuff burns out -- unused { isymbol = '`' , iname = "smoke" , ifreq = [("smoke", 1)] , iflavour = zipPlain [BrBlack] , icount = 16 , irarity = [(1, 1)] , iverbHit = "choke" -- or "obscure" , iweight = 1 , idamage = 0 , iaspects = [] , ieffects = [] , ifeature = [toVelocity 20, Fragile, Blast] -- 4 steps, 2 turns , idesc = "Twirling clouds of grey smoke." , ikit = [] } boilingWater = ItemKind { isymbol = '*' , iname = "boiling water" , ifreq = [("boiling water", 1)] , iflavour = zipPlain [White] , icount = 18 , irarity = [(1, 1)] , iverbHit = "boil" , iweight = 1 , idamage = 0 , iaspects = [] , ieffects = [Burn 1] , ifeature = [toVelocity 30, Fragile, Blast] -- 6 steps, 2 turns , idesc = "It bubbles and hisses." , ikit = [] } glue = ItemKind { isymbol = '*' , iname = "hoof glue" , ifreq = [("glue", 1)] , iflavour = zipPlain [Cyan] , icount = 8 -- Paralyze doesn't stack; avoid failure messages , irarity = [(1, 1)] , iverbHit = "glue" , iweight = 1 , idamage = 0 , iaspects = [] , ieffects = [Paralyze 10] , ifeature = [toVelocity 20, Fragile, Blast] -- 4 steps, 2 turns , idesc = "Thick and clinging." , ikit = [] } waste = ItemKind { isymbol = '*' , iname = "waste" , ifreq = [("waste", 1)] , iflavour = zipPlain [Brown] , icount = 16 , irarity = [(1, 1)] , iverbHit = "splosh" , iweight = 1 , idamage = 0 , iaspects = [] , ieffects = [Burn 1] , ifeature = [toLinger 10, Fragile, Blast] , idesc = "Sodden and foul-smelling." , ikit = [] } -- * Temporary condition blasts -- Almost all have @toLinger 10@, that travels 2 steps in 1 turn. -- These are very fast projectiles, not getting into the way of big -- actors and not burdening the engine for long. -- A few are slower 'mists'. denseShower = ItemKind { isymbol = '`' , iname = "dense shower" , ifreq = [("dense shower", 1)] , iflavour = zipFancy [Green] , icount = 12 , irarity = [(1, 1)] , iverbHit = "strengthen" , iweight = 1 , idamage = 0 , iaspects = [] , ieffects = [toOrganGood "strengthened" (3 + 1 `d` 3)] , ifeature = [toLinger 10, Fragile, Blast] , idesc = "A thick rain of droplets." , ikit = [] } sparseShower = ItemKind { isymbol = '`' , iname = "sparse shower" , ifreq = [("sparse shower", 1)] , iflavour = zipFancy [Red] , icount = 8 , irarity = [(1, 1)] , iverbHit = "weaken" , iweight = 1 , idamage = 0 , iaspects = [] , ieffects = [toOrganBad "weakened" (3 + 1 `d` 3)] , ifeature = [toLinger 10, Fragile, Blast] , idesc = "Light droplets that cling to clothing." , ikit = [] } protectingBalmMelee = ItemKind { isymbol = '`' , iname = "balm droplet" , ifreq = [("melee protective balm", 1)] , iflavour = zipFancy [Brown] , icount = 16 , irarity = [(1, 1)] , iverbHit = "balm" , iweight = 1 , idamage = 0 , iaspects = [] , ieffects = [toOrganGood "protected from melee" (3 + 1 `d` 3)] , ifeature = [toLinger 10, Fragile, Blast] , idesc = "A thick ointment that hardens the skin." , ikit = [] } protectingBalmRanged = ItemKind { isymbol = '`' , iname = "balm droplet" , ifreq = [("ranged protective balm", 1)] , iflavour = zipPlain [BrYellow] , icount = 16 , irarity = [(1, 1)] , iverbHit = "balm" , iweight = 1 , idamage = 0 , iaspects = [] , ieffects = [toOrganGood "protected from ranged" (3 + 1 `d` 3)] , ifeature = [toLinger 10, Fragile, Blast] , idesc = "Grease that protects from flying death." , ikit = [] } vulnerabilityBalm = ItemKind { isymbol = '?' , iname = "PhD defense question" , ifreq = [("PhD defense question", 1)] , iflavour = zipFancy [BrRed] , icount = 16 , irarity = [(1, 1)] , iverbHit = "nag" , iweight = 1 , idamage = 0 , iaspects = [] , ieffects = [toOrganBad "defenseless" (3 + 1 `d` 3)] , ifeature = [toLinger 10, Fragile, Blast] , idesc = "Only the most learned make use of this." , ikit = [] } resolutionDust = ItemKind { isymbol = '`' , iname = "resolution dust" , ifreq = [("resolution dust", 1)] , iflavour = zipPlain [Brown] , icount = 16 , irarity = [(1, 1)] , iverbHit = "calm" , iweight = 1 , idamage = 0 , iaspects = [] , ieffects = [toOrganGood "resolute" (3 + 1 `d` 3)] -- short enough duration that @calmEnough@ not a big problem , ifeature = [toLinger 10, Fragile, Blast] , idesc = "A handful of honest earth, to strengthen the soul." , ikit = [] } hasteSpray = ItemKind { isymbol = '`' , iname = "haste spray" , ifreq = [("haste spray", 1)] , iflavour = zipFancy [BrYellow] , icount = 16 , irarity = [(1, 1)] , iverbHit = "haste" , iweight = 1 , idamage = 0 , iaspects = [] , ieffects = [toOrganGood "hasted" (3 + 1 `d` 3)] , ifeature = [toLinger 10, Fragile, Blast] , idesc = "A quick spurt." , ikit = [] } slownessMist = ItemKind { isymbol = '`' , iname = "slowness mist" , ifreq = [("slowness mist", 1)] , iflavour = zipPlain [BrBlue] , icount = 8 , irarity = [(1, 1)] , iverbHit = "slow" , iweight = 0 , idamage = 0 , iaspects = [] , ieffects = [toOrganBad "slowed" (3 + 1 `d` 3)] , ifeature = [toVelocity 5, Fragile, Blast] -- 1 step, 1 turn, mist, slow , idesc = "Clammy fog, making each movement an effort." , ikit = [] } eyeDrop = ItemKind { isymbol = '`' , iname = "eye drop" , ifreq = [("eye drop", 1)] , iflavour = zipFancy [BrCyan] , icount = 16 , irarity = [(1, 1)] , iverbHit = "cleanse" , iweight = 1 , idamage = 0 , iaspects = [] , ieffects = [toOrganGood "far-sighted" (3 + 1 `d` 3)] , ifeature = [toLinger 10, Fragile, Blast] , idesc = "Not to be taken orally." , ikit = [] } ironFiling = ItemKind { isymbol = '`' , iname = "iron filing" , ifreq = [("iron filing", 1)] , iflavour = zipPlain [Red] , icount = 16 , irarity = [(1, 1)] , iverbHit = "blind" , iweight = 1 , idamage = 0 , iaspects = [] , ieffects = [toOrganBad "blind" (10 + 1 `d` 10)] , ifeature = [toLinger 10, Fragile, Blast] , idesc = "A shaving of bright metal." , ikit = [] } smellyDroplet = ItemKind { isymbol = '`' , iname = "smelly droplet" , ifreq = [("smelly droplet", 1)] , iflavour = zipFancy [Blue] , icount = 16 , irarity = [(1, 1)] , iverbHit = "sensitize" , iweight = 1 , idamage = 0 , iaspects = [] , ieffects = [toOrganGood "keen-smelling" (3 + 1 `d` 3)] , ifeature = [toLinger 10, Fragile, Blast] , idesc = "A viscous lump that stains the skin." , ikit = [] } eyeShine = ItemKind { isymbol = '`' , iname = "eye shine" , ifreq = [("eye shine", 1)] , iflavour = zipFancy [Cyan] , icount = 16 , irarity = [(1, 1)] , iverbHit = "smear" , iweight = 1 , idamage = 0 , iaspects = [] , ieffects = [toOrganGood "shiny-eyed" (3 + 1 `d` 3)] , ifeature = [toLinger 10, Fragile, Blast] , idesc = "They almost glow in the dark." , ikit = [] } whiskeySpray = ItemKind { isymbol = '`' , iname = "whiskey spray" , ifreq = [("whiskey spray", 1)] , iflavour = zipFancy [Brown] , icount = 16 , irarity = [(1, 1)] , iverbHit = "inebriate" , iweight = 1 , idamage = 0 , iaspects = [] , ieffects = [toOrganGood "drunk" (3 + 1 `d` 3)] , ifeature = [toLinger 10, Fragile, Blast] , idesc = "It burns in the best way." , ikit = [] } youthSprinkle = ItemKind { isymbol = '`' , iname = "youth sprinkle" , ifreq = [("youth sprinkle", 1)] , iflavour = zipFancy [BrGreen] , icount = 16 , irarity = [(1, 1)] , iverbHit = "sprinkle" , iweight = 1 , idamage = 0 , iaspects = [] , ieffects = [toOrganNoTimer "regenerating"] , ifeature = [toLinger 10, Fragile, Blast] , idesc = "Bright and smelling of the Spring." , ikit = [] } poisonCloud = ItemKind { isymbol = '`' , iname = "poison cloud" , ifreq = [("poison cloud", 1)] , iflavour = zipFancy [BrMagenta] , icount = 16 , irarity = [(1, 1)] , iverbHit = "poison" , iweight = 0 , idamage = 0 , iaspects = [] , ieffects = [toOrganNoTimer "poisoned"] , ifeature = [toVelocity 10, Fragile, Blast] -- 2 steps, 2 turns , idesc = "Choking gas that stings the eyes." , ikit = [] } mistAntiSlow = ItemKind { isymbol = '`' , iname = "mist" , ifreq = [("anti-slow mist", 1)] , iflavour = zipFancy [BrYellow] , icount = 8 , irarity = [(1, 1)] , iverbHit = "propel" , iweight = 1 , idamage = 0 , iaspects = [] , ieffects = [DropItem 1 1 COrgan "slowed"] , ifeature = [toVelocity 5, Fragile, Blast] -- 1 step, 1 turn , idesc = "A cleansing rain." , ikit = [] } mistAntidote = ItemKind { isymbol = '`' , iname = "mist" , ifreq = [("antidote mist", 1)] , iflavour = zipFancy [BrBlue] , icount = 8 , irarity = [(1, 1)] , iverbHit = "cure" , iweight = 1 , idamage = 0 , iaspects = [] , ieffects = [DropItem 1 maxBound COrgan "poisoned"] , ifeature = [toVelocity 5, Fragile, Blast] -- 1 step, 1 turn , idesc = "Washes away death's dew." , ikit = [] } LambdaHack-0.8.3.0/GameDefinition/Content/PlaceKind.hs0000644000000000000000000004233513315545734020520 0ustar0000000000000000-- | Room, hall and passage definitions. module Content.PlaceKind ( content ) where import Prelude () import Game.LambdaHack.Common.Prelude import Game.LambdaHack.Common.Misc import Game.LambdaHack.Content.PlaceKind content :: [PlaceKind] content = [rect, rectWindows, glasshouse, pulpit, ruin, collapsed, collapsed2, collapsed3, collapsed4, collapsed5, collapsed6, collapsed7, pillar, pillar2, pillar3, pillar4, colonnade, colonnade2, colonnade3, colonnade4, colonnade5, colonnade6, lampPost, lampPost2, lampPost3, lampPost4, treeShade, fogClump, fogClump2, smokeClump, smokeClump2FGround, bushClump, staircase, staircase2, staircase3, staircase4, staircase5, staircase6, staircase7, staircase8, staircase9, staircase10, staircase11, staircase12, staircase13, staircase14, staircase15, staircase16, staircase17, staircaseOutdoor, staircaseGated, escapeUp, escapeUp2, escapeUp3, escapeUp4, escapeUp5, escapeDown, escapeDown2, escapeDown3, escapeDown4, escapeDown5, escapeOutdoorDown] ++ map makeStaircaseUp lstaircase ++ map makeStaircaseDown lstaircase rect, rectWindows, glasshouse, pulpit, ruin, collapsed, collapsed2, collapsed3, collapsed4, collapsed5, collapsed6, collapsed7, pillar, pillar2, pillar3, pillar4, colonnade, colonnade2, colonnade3, colonnade4, colonnade5, colonnade6, lampPost, lampPost2, lampPost3, lampPost4, treeShade, fogClump, fogClump2, smokeClump, smokeClump2FGround, bushClump, staircase, staircase2, staircase3, staircase4, staircase5, staircase6, staircase7, staircase8, staircase9, staircase10, staircase11, staircase12, staircase13, staircase14, staircase15, staircase16, staircase17, staircaseOutdoor, staircaseGated, escapeUp, escapeUp2, escapeUp3, escapeUp4, escapeUp5, escapeDown, escapeDown2, escapeDown3, escapeDown4, escapeDown5, escapeOutdoorDown :: PlaceKind lstaircase :: [PlaceKind] lstaircase = [staircase, staircase2, staircase3, staircase4, staircase5, staircase6, staircase7, staircase8, staircase9, staircase10, staircase11, staircase12, staircase13, staircase14, staircase15, staircase16, staircase17, staircaseOutdoor, staircaseGated] -- The dots below are @Char.chr 183@, as defined in @TileKind.floorSymbol@. rect = PlaceKind -- Valid for any nonempty area, hence low frequency. { psymbol = 'r' , pname = "room" , pfreq = [("rogue", 100), ("arena", 40), ("laboratory", 40), ("zoo", 9)] , prarity = [(1, 10), (10, 8)] , pcover = CStretch , pfence = FNone , ptopLeft = [ "--" , "|·" ] , poverride = [] } rectWindows = PlaceKind { psymbol = 'w' , pname = "room" , pfreq = [("empty", 10), ("park", 6)] , prarity = [(1, 10), (10, 8)] , pcover = CStretch , pfence = FNone , ptopLeft = [ "-=" , "!·" ] , poverride = [('=', "rectWindowsOver_=_Lit"), ('!', "rectWindowsOver_!_Lit")] -- for now I need to specify 'Lit' or I'd be randomly getting lit and dark -- tiles, until ooverride is extended to take night/dark into account } glasshouse = PlaceKind { psymbol = 'g' , pname = "glasshouse" , pfreq = [("arena", 40), ("shootout", 8), ("zoo", 9)] , prarity = [(1, 10), (10, 8)] , pcover = CStretch , pfence = FNone , ptopLeft = [ "==" , "!·" ] , poverride = [('=', "glasshouseOver_=_Lit"), ('!', "glasshouseOver_!_Lit")] } pulpit = PlaceKind { psymbol = 'p' , pname = "pulpit" , pfreq = [("arena", 10), ("zoo", 30)] , prarity = [(1, 10), (10, 8)] , pcover = CMirror , pfence = FGround , ptopLeft = [ "==·" , "!··" , "··O" ] , poverride = [ ('=', "glasshouseOver_=_Lit"), ('!', "glasshouseOver_!_Lit") , ('O', "pulpit") ] -- except for floor, this will all be lit, regardless of night/dark; OK } ruin = PlaceKind { psymbol = 'R' , pname = "ruin" , pfreq = [("battle", 33), ("noise", 50)] , prarity = [(1, 10), (10, 20)] , pcover = CStretch , pfence = FNone , ptopLeft = [ "--" , "|X" ] , poverride = [] } collapsed = PlaceKind -- in a dark cave, they have little lights --- that's OK { 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", 20)] , ptopLeft = [ "XO" , "OO" ] } collapsed3 = collapsed { pfreq = [("noise", 200), ("battle", 20)] , ptopLeft = [ "XXO" , "OOO" ] } collapsed4 = collapsed { pfreq = [("noise", 200), ("battle", 20)] , ptopLeft = [ "XXXO" , "OOOO" ] } collapsed5 = collapsed { pfreq = [("noise", 300), ("battle", 50)] , ptopLeft = [ "XXO" , "XOO" , "OOO" ] } collapsed6 = collapsed { pfreq = [("noise", 400), ("battle", 100)] , ptopLeft = [ "XXXO" , "XOOO" , "OOOO" ] } collapsed7 = collapsed { pfreq = [("noise", 400), ("battle", 100)] , ptopLeft = [ "XXXO" , "XXOO" , "OOOO" ] } pillar = PlaceKind { psymbol = 'p' , pname = "pillar room" , pfreq = [ ("rogue", 500), ("arena", 1000), ("laboratory", 1000) , ("empty", 300), ("noise", 1000) ] , prarity = [(1, 10), (10, 10)] , pcover = CStretch , pfence = FNone -- Larger rooms require support pillars. , ptopLeft = [ "-----" , "|····" , "|·O··" , "|····" , "|····" ] , poverride = [('&', "cache")] } pillar2 = pillar { ptopLeft = [ "-----" , "|O···" , "|····" , "|····" , "|····" ] } pillar3 = pillar { prarity = [(10, 5)] , ptopLeft = [ "-----" , "|&·O·" , "|····" , "|O·O·" , "|····" ] } pillar4 = pillar { prarity = [(10, 5)] , ptopLeft = [ "-----" , "|&·O·" , "|····" , "|O···" , "|····" ] } colonnade = PlaceKind { psymbol = 'c' , pname = "colonnade" , pfreq = [ ("rogue", 30), ("arena", 70), ("laboratory", 40) , ("empty", 100), ("mine", 10000), ("park", 4000) ] , prarity = [(1, 3), (10, 3)] , pcover = CAlternate , pfence = FFloor , ptopLeft = [ "O·" , "·O" ] , poverride = [] } colonnade2 = colonnade { prarity = [(1, 2), (10, 2)] , ptopLeft = [ "O·" , "··" ] } colonnade3 = colonnade { prarity = [(1, 12), (10, 12)] , ptopLeft = [ "··O" , "·O·" , "O··" ] } colonnade4 = colonnade { prarity = [(1, 12), (10, 12)] , ptopLeft = [ "O··" , "·O·" , "··O" ] } colonnade5 = colonnade { prarity = [(1, 7), (10, 7)] , ptopLeft = [ "O··" , "··O" ] } colonnade6 = colonnade { ptopLeft = [ "O·" , "··" , "·O" ] } lampPost = PlaceKind { psymbol = 'l' , pname = "lamp post" , pfreq = [("park", 20), ("zoo", 10), ("battle", 10)] , prarity = [(1, 10), (10, 10)] , pcover = CVerbatim , pfence = FNone , ptopLeft = [ "X·X" , "·O·" , "X·X" ] , poverride = [('O', "lampPostOver_O"), ('·', "floorActorLit")] } lampPost2 = lampPost { ptopLeft = [ "···" , "·O·" , "···" ] } lampPost3 = lampPost { pfreq = [("park", 3000), ("zoo", 50), ("battle", 110)] , ptopLeft = [ "XX·XX" , "X···X" , "··O··" , "X···X" , "XX·XX" ] } lampPost4 = lampPost { pfreq = [("park", 3000), ("zoo", 50), ("battle", 60)] , ptopLeft = [ "X···X" , "·····" , "··O··" , "·····" , "X···X" ] } treeShade = PlaceKind { psymbol = 't' , pname = "tree shade" , pfreq = [("brawl", 300)] , prarity = [(1, 10), (10, 10)] , pcover = CMirror , pfence = FNone , ptopLeft = [ "··s" , "sO·" , "Xs·" ] , poverride = [ ('O', "treeShadeOver_O_Lit"), ('s', "treeShadeOver_s_Lit") , ('·', "shaded ground") ] } fogClump = PlaceKind { psymbol = 'f' , pname = "foggy patch" , pfreq = [("shootout", 170)] , prarity = [(1, 1)] , pcover = CMirror , pfence = FNone , ptopLeft = [ "f;" , ";f" , ";f" ] , poverride = [('f', "fogClumpOver_f_Lit"), (';', "lit fog")] } fogClump2 = fogClump { pfreq = [("shootout", 400), ("empty", 1500)] , prarity = [(1, 1)] , pcover = CMirror , pfence = FNone , ptopLeft = [ "Xff" , "f;f" , ";;f" , "XfX" ] } smokeClump = PlaceKind { psymbol = 's' , pname = "smoky patch" , pfreq = [("zoo", 50)] , prarity = [(1, 1)] , pcover = CMirror , pfence = FNone , ptopLeft = [ "f;" , ";f" , ";f" ] , poverride = [ ('f', "smokeClumpOver_f_Lit"), (';', "lit smoke") , ('·', "floorActorLit") ] } smokeClump2FGround = smokeClump { pfreq = [("laboratory", 100), ("zoo", 500)] , prarity = [(1, 1)] , pcover = CMirror , pfence = FGround , ptopLeft = [ ";f;" , "f·f" , ";·f" , ";f;" ] } bushClump = PlaceKind { psymbol = 'b' , pname = "bushy patch" , pfreq = [("shootout", 120)] , prarity = [(1, 1)] , pcover = CMirror , pfence = FNone , ptopLeft = [ "f;" , ";f" , ";f" ] , poverride = [('f', "bushClumpOver_f_Lit"), (';', "bush Lit")] } staircase = PlaceKind { psymbol = '|' , pname = "staircase" , pfreq = [("staircase", 1)] , prarity = [(1, 1)] , pcover = CVerbatim , pfence = FGround , ptopLeft = [ "<·>" ] , poverride = [ ('<', "staircase up"), ('>', "staircase down") , ('I', "signboard") ] } staircase2 = staircase { pfreq = [("staircase", 1000)] , pfence = FFloor , ptopLeft = [ "O·O" , "···" , "<·>" , "···" , "O·O" ] } staircase3 = staircase { pfreq = [("staircase", 1000)] , pfence = FFloor , ptopLeft = [ "O·I·O" , "·····" , "·<·>·" , "·····" , "O·I·O" ] } staircase4 = staircase { pfreq = [("staircase", 1000)] , pfence = FFloor , ptopLeft = [ "O·O·O·O" , "·······" , "O·<·>·O" , "·······" , "O·O·O·O" ] } staircase5 = staircase { pfreq = [("staircase", 100)] , pfence = FGround , ptopLeft = [ "O·<·>·O" ] } staircase6 = staircase { pfreq = [("staircase", 100)] , pfence = FGround , ptopLeft = [ "O··<·>··O" ] } staircase7 = staircase { pfreq = [("staircase", 100)] , pfence = FGround , ptopLeft = [ "I·O·<·>·O·I" ] } staircase8 = staircase { pfreq = [("staircase", 1000)] , pfence = FFloor , ptopLeft = [ "O·····O" , "··<·>··" , "O·····O" ] } staircase9 = staircase { pfreq = [("staircase", 1000)] , pfence = FFloor , ptopLeft = [ "O·······O" , "·O·<·>·O·" , "O·······O" ] } staircase10 = staircase { pfreq = [("staircase", 1000)] , pfence = FFloor , ptopLeft = [ "O·O·····O·O" , "·O··<·>··O·" , "O·O·····O·O" ] } staircase11 = staircase { pfreq = [("staircase", 10000)] , pfence = FGround , ptopLeft = [ "··O·O··" , "O·····O" , "··<·>··" , "O·····O" , "··O·O··" ] } staircase12 = staircase { pfreq = [("staircase", 1000)] , pfence = FNone , ptopLeft = [ "-------" , "|·····|" , "|·<·>·|" , "|·····|" , "-------" ] } staircase13 = staircase { pfreq = [("staircase", 1000)] , pfence = FNone , ptopLeft = [ "---------" , "|·······|" , "|O·<·>·O|" , "|·······|" , "---------" ] } staircase14 = staircase { pfreq = [("staircase", 1000)] , pfence = FNone , ptopLeft = [ "-----------" , "|·········|" , "|·O·<·>·O·|" , "|·········|" , "-----------" ] } staircase15 = staircase { pfreq = [("staircase", 1000)] , pfence = FNone , ptopLeft = [ "-------------" , "|···········|" , "|O·I·<·>·I·O|" , "|···········|" , "-------------" ] } staircase16 = staircase { pfreq = [("staircase", 1000)] , pfence = FNone , ptopLeft = [ "---------" , "|O·····O|" , "|··<·>··|" , "|O·····O|" , "---------" ] } staircase17 = staircase { pfreq = [("staircase", 1000)] , pfence = FNone , ptopLeft = [ "-----------" , "|O·······O|" , "|·O·<·>·O·|" , "|O·······O|" , "-----------" ] } staircaseOutdoor = staircase { pname = "staircase outdoor" , pfreq = [("staircase outdoor", 1)] , poverride = [('<', "staircase outdoor up"), ('>', "staircase outdoor down")] } staircaseGated = staircase { pname = "gated staircase" , pfreq = [("gated staircase", 1)] , poverride = [('<', "gated staircase up"), ('>', "gated staircase down")] } escapeUp = PlaceKind { psymbol = '<' , pname = "escape up" , pfreq = [("escape up", 1)] , prarity = [(1, 1)] , pcover = CVerbatim , pfence = FGround , ptopLeft = [ "<" ] , poverride = [] } escapeUp2 = escapeUp { pfreq = [("escape up", 1000)] , pfence = FFloor , ptopLeft = [ "O·O" , "·<·" , "O·O" ] } escapeUp3 = escapeUp { pfreq = [("escape down", 2000)] , pcover = CMirror , pfence = FFloor , ptopLeft = [ "O··" , "·<·" , "O·O" ] } escapeUp4 = escapeUp { pfreq = [("escape up", 1000)] , pfence = FNone , ptopLeft = [ "-----" , "|O·O|" , "|·<·|" , "|O·O|" , "-----" ] } escapeUp5 = escapeUp { pfreq = [("escape up", 2000)] , pcover = CMirror , pfence = FNone , ptopLeft = [ "-----" , "|O··|" , "|·<·|" , "|O·O|" , "-----" ] } escapeDown = PlaceKind { psymbol = '>' , pname = "escape down" , pfreq = [("escape down", 1)] , prarity = [(1, 1)] , pcover = CVerbatim , pfence = FGround , ptopLeft = [ ">" ] , poverride = [] } escapeDown2 = escapeDown { pfreq = [("escape down", 1000)] , pfence = FFloor , ptopLeft = [ "O·O" , "·>·" , "O·O" ] } escapeDown3 = escapeDown { pfreq = [("escape down", 2000)] , pcover = CMirror , pfence = FFloor , ptopLeft = [ "O··" , "·>·" , "O·O" ] } escapeDown4 = escapeDown { pfreq = [("escape down", 1000)] , pfence = FNone , ptopLeft = [ "-----" , "|O·O|" , "|·>·|" , "|O·O|" , "-----" ] } escapeDown5 = escapeDown { pfreq = [("escape down", 2000)] , pcover = CMirror , pfence = FNone , ptopLeft = [ "-----" , "|O··|" , "|·>·|" , "|O·O|" , "-----" ] } escapeOutdoorDown = escapeDown { pfreq = [("escape outdoor down", 1)] , poverride = [('>', "escape outdoor down")] } makeStaircaseUp :: PlaceKind -> PlaceKind makeStaircaseUp s = s { psymbol = '<' , pname = pname s <+> "up" , pfreq = map (\(t, k) -> (toGroupName $ tshow t <+> "up", k)) $ pfreq s , poverride = ('>', "stair terminal") : filter ((/= '>') . fst) (poverride s) } makeStaircaseDown :: PlaceKind -> PlaceKind makeStaircaseDown s = s { psymbol = '>' , pname = pname s <+> "down" , pfreq = map (\(t, k) -> (toGroupName $ tshow t <+> "down", k)) $ pfreq s , poverride = ('<', "stair terminal") : filter ((/= '<') . fst) (poverride s) } LambdaHack-0.8.3.0/GameDefinition/Content/RuleKind.hs0000644000000000000000000000517713315545734020406 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} -- | Game rules and assorted game setup data. module Content.RuleKind ( content ) where import Prelude () import Game.LambdaHack.Common.Prelude import Language.Haskell.TH.Syntax import System.FilePath import System.IO (readFile) -- Cabal import qualified Paths_LambdaHack as Self (getDataFileName, version) import Game.LambdaHack.Content.RuleKind content :: [RuleKind] content = [standard] standard :: RuleKind standard = RuleKind { rsymbol = 's' , rname = "standard LambdaHack ruleset" , rfreq = [("standard", 100)] , rtitle = "LambdaHack" , rfontDir = $(do x <- qRunIO (Self.getDataFileName "GameDefinition/fonts") lift x) , rexeVersion = Self.version -- The strings containing the default configuration file -- included from config.ui.default. , rcfgUIName = "config.ui" <.> "ini" , rcfgUIDefault = $(do let path = "GameDefinition" "config.ui" <.> "default" qAddDependentFile path x <- qRunIO (readFile path) lift x) -- ASCII art for the main menu. Only pure 7-bit ASCII characters are allowed. -- When displayed in the main menu screen, the picture is overwritten -- with game and engine version strings and keybindings. -- The keybindings overwrite places marked with left curly brace signs. -- This sign is forbidden anywhere else in the picture. -- The picture and the whole main menu is displayed dull white on black. -- The glyphs, or at least the character cells, are perfect squares. -- The picture should be exactly 45 rows by 80 columns. -- For larger screen sizes, the picture is centered and padded with spaces, -- so it makes sense for some or all of the picture borders to be spaces. , rmainMenuArt = $(do let path = "GameDefinition/MainMenu.ascii" qAddDependentFile path x <- qRunIO (readFile path) lift x) , rintroScreen = $(do let path = "GameDefinition/PLAYING.md" qAddDependentFile path x <- qRunIO (readFile path) let paragraphs :: [String] -> [String] -> [[String]] paragraphs [] rows = [reverse rows] paragraphs (l : ls) rows = if null l then reverse rows : paragraphs ls [] else paragraphs ls (l : rows) intro = case paragraphs (lines x) [] of _title : _blurb : par1 : par2 : _rest -> ["", ""] ++ par1 ++ [""] ++ par2 ++ ["", ""] _ -> error "not enough paragraphs in intro screen text" lift intro) , rfirstDeathEnds = False , rwriteSaveClips = 1000 , rleadLevelClips = 50 , rscoresFile = "LambdaHack.scores" , rnearby = 20 } LambdaHack-0.8.3.0/GameDefinition/Content/ItemKind.hs0000644000000000000000000017442113315545734020374 0ustar0000000000000000-- | Item definitions. module Content.ItemKind ( content, items, otherItemContent ) where import Prelude () import Game.LambdaHack.Common.Prelude import Content.ItemKindActor import Content.ItemKindBlast import Content.ItemKindEmbed import Content.ItemKindOrgan import Content.ItemKindTemporary import Game.LambdaHack.Common.Ability import Game.LambdaHack.Common.Color import Game.LambdaHack.Common.Dice import Game.LambdaHack.Common.Flavour import Game.LambdaHack.Common.ItemAspect (Aspect (..), EqpSlot (..)) import Game.LambdaHack.Common.Misc import Game.LambdaHack.Content.ItemKind content :: [ItemKind] content = items ++ otherItemContent otherItemContent :: [ItemKind] otherItemContent = embeds ++ actors ++ organs ++ blasts ++ temporaries items :: [ItemKind] items = [sandstoneRock, dart, spike, spike2, slingStone, slingBullet, paralizingProj, harpoon, harpoon2, net, light1, light2, light3, blanket, flaskTemplate, flask1, flask2, flask3, flask4, flask5, flask6, flask7, flask8, flask9, flask10, flask11, flask12, flask13, flask14, flask15, flask16, flask17, flask18, flask19, flask20, potionTemplate, potion1, potion2, potion3, potion4, potion5, potion6, potion7, potion8, potion9, fragmentationBomb, concussionBomb, flashBomb, firecrackerBomb, scrollTemplate, scroll1, scroll2, scroll3, scroll4, scroll5, scroll6, scroll7, scroll8, scroll9, scroll10, scroll11, scroll12, scroll13, jumpingPole, sharpeningTool, seeingItem, motionScanner, gorget, necklaceTemplate, necklace1, necklace2, necklace3, necklace4, necklace5, necklace6, necklace7, necklace8, necklace9, imageItensifier, sightSharpening, ringTemplate, ring1, ring2, ring3, ring4, ring5, ring6, ring7, ring8, armorLeather, armorMail, gloveFencing, gloveGauntlet, gloveJousting, buckler, shield, shield2, shield3, dagger, daggerDropBestWeapon, hammer, hammer2, hammer3, hammerParalyze, hammerSpark, sword, swordImpress, swordNullify, halberd, halberd2, halberd3, halberdPushActor, wandTemplate, wand1, gemTemplate, gem1, gem2, gem3, gem4, gem5, currencyTemplate, currency] sandstoneRock, dart, spike, spike2, slingStone, slingBullet, paralizingProj, harpoon, harpoon2, net, light1, light2, light3, blanket, flaskTemplate, flask1, flask2, flask3, flask4, flask5, flask6, flask7, flask8, flask9, flask10, flask11, flask12, flask13, flask14, flask15, flask16, flask17, flask18, flask19, flask20, potionTemplate, potion1, potion2, potion3, potion4, potion5, potion6, potion7, potion8, potion9, fragmentationBomb, concussionBomb, flashBomb, firecrackerBomb, scrollTemplate, scroll1, scroll2, scroll3, scroll4, scroll5, scroll6, scroll7, scroll8, scroll9, scroll10, scroll11, scroll12, scroll13, jumpingPole, sharpeningTool, seeingItem, motionScanner, gorget, necklaceTemplate, necklace1, necklace2, necklace3, necklace4, necklace5, necklace6, necklace7, necklace8, necklace9, imageItensifier, sightSharpening, ringTemplate, ring1, ring2, ring3, ring4, ring5, ring6, ring7, ring8, armorLeather, armorMail, gloveFencing, gloveGauntlet, gloveJousting, buckler, shield, shield2, shield3, dagger, daggerDropBestWeapon, hammer, hammer2, hammer3, hammerParalyze, hammerSpark, sword, swordImpress, swordNullify, halberd, halberd2, halberd3, halberdPushActor, wandTemplate, wand1, gemTemplate, gem1, gem2, gem3, gem4, gem5, currencyTemplate, currency :: ItemKind -- Keep the dice rolls and sides in aspects small so that not too many -- distinct items are generated (for display in item lore and for narrative -- impact ("oh, I found the more powerful of the two variants of the item!", -- instead of "hmm, I found one of the countless variants, a decent one"). -- In particular, for unique items, unless they inherit aspects from -- a standard item, permit only a couple possible variants. -- This is especially important if an item kind has mulitple random aspects. -- Instead multiply dice results, e.g., (1 `d` 3) * 5 instead of 1 `d` 15. -- -- Beware of non-periodic non-weapon durable items with beneficial effects -- and low timeout -- AI will starve applying such an item incessantly. -- * Item group symbols, partially from Nethack symbolProjectile, _symbolLauncher, symbolLight, symbolTool, symbolSpecial, symbolGold, symbolNecklace, symbolRing, symbolPotion, symbolFlask, symbolScroll, symbolTorsoArmor, symbolMiscArmor, _symbolClothes, symbolShield, symbolPolearm, symbolEdged, symbolHafted, symbolWand, _symbolStaff, symbolFood :: Char symbolProjectile = '|' _symbolLauncher = '}' symbolLight = '(' symbolTool = '(' symbolSpecial = '*' -- don't overuse, because it clashes with projectiles symbolGold = '$' -- also gems symbolNecklace = '"' symbolRing = '=' symbolPotion = '!' -- concoction, bottle, jar, vial, canister symbolFlask = '!' symbolScroll = '?' -- book, note, tablet, remote, chip, card symbolTorsoArmor = '[' symbolMiscArmor = '[' _symbolClothes = '[' symbolShield = ']' symbolPolearm = ')' symbolEdged = ')' symbolHafted = ')' symbolWand = '/' -- magical rod, transmitter, pistol, rifle, instrument _symbolStaff = '_' -- scanner symbolFood = ',' -- also body part; distinct from floor: not middle dot -- * Thrown weapons sandstoneRock = ItemKind { isymbol = symbolProjectile , iname = "sandstone rock" , ifreq = [("sandstone rock", 1), ("weak arrow", 10)] , iflavour = zipPlain [Green] , icount = 1 `d` 2 , irarity = [(1, 50), (10, 1)] , iverbHit = "hit" , iweight = 300 , idamage = 1 `d` 1 , iaspects = [AddHurtMelee $ -16 * 5] , ieffects = [] , ifeature = [toVelocity 70, Fragile] -- not dense, irregular , idesc = "A lump of brittle sandstone rock." , ikit = [] } dart = ItemKind { isymbol = symbolProjectile , iname = "dart" , ifreq = [("common item", 100), ("any arrow", 50), ("weak arrow", 50)] , iflavour = zipPlain [BrRed] , icount = 4 `dL` 5 , irarity = [(1, 20), (10, 10)] , iverbHit = "prick" , iweight = 40 , idamage = 1 `d` 1 , iaspects = [AddHurtMelee $ (-15 + 1 `d` 2 + 1 `dL` 3) * 5] -- only leather-piercing , ieffects = [] , ifeature = [] , idesc = "A sharp delicate dart with fins." , ikit = [] } spike = ItemKind { isymbol = symbolProjectile , iname = "spike" , ifreq = [("common item", 100), ("any arrow", 50), ("weak arrow", 50)] , iflavour = zipPlain [Cyan] , icount = 4 `dL` 5 , irarity = [(1, 10), (10, 15)] , iverbHit = "nick" , iweight = 150 , idamage = 2 `d` 1 , iaspects = [AddHurtMelee $ (-10 + 1 `d` 2 + 1 `dL` 3) * 5] -- heavy vs armor , ieffects = [ Explode "single spark" -- when hitting enemy , OnSmash (Explode "single spark") ] -- at wall hit -- this results in a wordy item synopsis, but it's OK, the spark really -- is useful in some situations, not just a flavour , ifeature = [MinorEffects, toVelocity 70] -- hitting with tip costs speed , idesc = "A cruel long nail with small head." -- "Much inferior to arrows though, especially given the contravariance problems." -- funny, but destroy the suspension of disbelief; this is supposed to be a Lovecraftian horror and any hilarity must ensue from the failures in making it so and not from actively trying to be funny; also, mundane objects are not supposed to be scary or transcendental; the scare is in horrors from the abstract dimension visiting our ordinary reality; without the contrast there's no horror and no wonder, so also the magical items must be contrasted with ordinary XIX century and antique items , ikit = [] } spike2 = spike { ifreq = [("common item", 2), ("any arrow", 1), ("weak arrow", 1)] , iweight = 200 , idamage = 4 `d` 1 -- , idesc = "" } slingStone = ItemKind { isymbol = symbolProjectile , iname = "sling stone" , ifreq = [("common item", 5), ("any arrow", 100)] , iflavour = zipPlain [Blue] , icount = 3 `dL` 4 , irarity = [(1, 1), (10, 20)] , iverbHit = "hit" , iweight = 200 , idamage = 1 `d` 1 , iaspects = [AddHurtMelee $ (-10 + 1 `d` 2 + 1 `dL` 3) * 5] -- heavy vs armor , ieffects = [ Explode "single spark" -- when hitting enemy , OnSmash (Explode "single spark") ] -- at wall hit , ifeature = [MinorEffects, toVelocity 150] , idesc = "A round stone, carefully sized and smoothed to fit the pouch of a standard string and cloth sling." , ikit = [] } slingBullet = ItemKind { isymbol = symbolProjectile , iname = "sling bullet" , ifreq = [("common item", 5), ("any arrow", 100)] , iflavour = zipPlain [BrBlack] , icount = 6 `dL` 4 , irarity = [(1, 1), (10, 15)] , iverbHit = "hit" , iweight = 28 , idamage = 1 `d` 1 , iaspects = [AddHurtMelee $ (-17 + 1 `d` 2 + 1 `dL` 3) * 5] -- not armor-piercing , ieffects = [] , ifeature = [toVelocity 200] , idesc = "Small almond-shaped leaden projectile that weighs more than the sling used to tie the bag. It doesn't drop out of the sling's pouch when swung and doesn't snag when released." , ikit = [] } -- * Exotic thrown weapons -- Identified, because shape (and name) says it all. Detailed stats id by use. paralizingProj = ItemKind { isymbol = symbolProjectile , iname = "bolas set" , ifreq = [("common item", 100)] , iflavour = zipPlain [BrGreen] , icount = 1 `dL` 4 , irarity = [(5, 5), (10, 5)] , iverbHit = "entangle" , iweight = 500 , idamage = 1 `d` 1 , iaspects = [AddHurtMelee $ -14 * 5] , ieffects = [Paralyze 15, DropBestWeapon] , ifeature = [] , 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 = [("common item", 100), ("harpoon", 100)] , iflavour = zipPlain [Brown] , icount = 1 `dL` 5 , irarity = [(10, 10)] , iverbHit = "hook" , iweight = 750 , idamage = 5 `d` 1 , iaspects = [AddHurtMelee $ (-10 + 1 `d` 2 + 1 `dL` 3) * 5] , ieffects = [PullActor (ThrowMod 200 50)] , ifeature = [] , idesc = "The cruel, barbed head lodges in its victim so painfully that the weakest tug of the thin line sends the victim flying." , ikit = [] } harpoon2 = harpoon { ifreq = [("common item", 2), ("harpoon", 2)] , iweight = 1000 , idamage = 10 `d` 1 -- , idesc = "" } net = ItemKind { isymbol = symbolProjectile , iname = "net" , ifreq = [("common item", 100)] , iflavour = zipPlain [White] , icount = 1 `dL` 3 , irarity = [(3, 5), (10, 4)] , iverbHit = "entangle" , iweight = 1000 , idamage = 2 `d` 1 , iaspects = [AddHurtMelee $ -14 * 5] , ieffects = [ toOrganBad "slowed" (3 + 1 `d` 3) , DropItem maxBound 1 CEqp "torso armor" , SendFlying (ThrowMod 100 50) ] -- make the drop painful -- only one of each kind is dropped, because no rubbish in this group , ifeature = [] , idesc = "A wide net with weights along the edges. Entangles armor and restricts movement." , ikit = [] } -- * Lights light1 = ItemKind { isymbol = symbolLight , iname = "wooden torch" , ifreq = [ ("common item", 100), ("light source", 100) , ("wooden torch", 1) ] , iflavour = zipPlain [Brown] , icount = 1 `dL` 4 , irarity = [(1, 15)] , iverbHit = "scorch" , iweight = 1000 , idamage = 0 , iaspects = [ AddShine 3 -- not only flashes, but also sparks, , AddSight (-2) ] -- so unused by AI due to the mixed blessing , ieffects = [Burn 1] , ifeature = [Lobable, Equipable, EqpSlot EqpSlotLightSource] -- not Fragile; reusable flare , idesc = "A heavy smoking wooden torch, improvised using a cloth soaked in tar, burning in an unsteady glow." , ikit = [] } light2 = ItemKind { isymbol = symbolLight , iname = "oil lamp" , ifreq = [("common item", 100), ("light source", 100)] , iflavour = zipPlain [BrYellow] , icount = 1 `dL` 2 , irarity = [(6, 8)] , iverbHit = "burn" , iweight = 1500 , idamage = 1 `d` 1 , iaspects = [AddShine 3, AddSight (-1)] , ieffects = [Burn 1, Paralyze 6, OnSmash (Explode "burning oil 2")] , ifeature = [Lobable, Fragile, Equipable, EqpSlot EqpSlotLightSource ] , idesc = "A clay lamp filled with plant oil feeding a tiny wick." , ikit = [] } light3 = ItemKind { isymbol = symbolLight , iname = "brass lantern" , ifreq = [("common item", 100), ("light source", 100)] , iflavour = zipPlain [BrWhite] , icount = 1 , irarity = [(10, 6)] , iverbHit = "burn" , iweight = 3000 , idamage = 4 `d` 1 , iaspects = [AddShine 4, AddSight (-1)] , ieffects = [Burn 1, Paralyze 8, OnSmash (Explode "burning oil 4")] , ifeature = [Lobable, Fragile, Equipable, EqpSlot EqpSlotLightSource] , idesc = "Very bright and very heavy brass lantern." , ikit = [] } blanket = ItemKind { isymbol = symbolLight , iname = "wool blanket" , ifreq = [("common item", 100), ("light source", 100), ("blanket", 1)] , iflavour = zipPlain [BrBlack] , icount = 1 , irarity = [(1, 3)] , iverbHit = "swoosh" , iweight = 1000 , idamage = 0 , iaspects = [ AddShine (-10) -- douses torch, lamp and lantern in one action , AddArmorMelee 1, AddMaxCalm 2 ] , ieffects = [] , ifeature = [Lobable, Equipable] -- not Fragile; reusable douse , idesc = "Warm, comforting, and concealing, woven from soft wool." , ikit = [] } -- * Exploding consumables, often intended to be thrown. -- Not identified, because they are perfect for the id-by-use fun, -- due to effects. They are fragile and upon hitting the ground explode -- for effects roughly corresponding to their normal effects. -- Whether to hit with them or explode them close to the tartget -- is intended to be an interesting tactical decision. -- -- Flasks are often not natural; maths, magic, distillery. -- In reality, they just cover all conditions, which in turn matches -- all aspects. -- -- There is no flask nor temporary organ of Calm depletion, -- because Calm reduced often via combat, etc.. flaskTemplate = ItemKind { isymbol = symbolFlask , iname = "flask" , ifreq = [("flask unknown", 1)] , iflavour = zipLiquid darkCol ++ zipPlain darkCol ++ zipFancy darkCol ++ zipLiquid brightCol , icount = 1 `dL` 3 , irarity = [(1, 7), (10, 3)] , iverbHit = "splash" , iweight = 500 , idamage = 0 , iaspects = [] , ieffects = [] , ifeature = [ HideAs "flask unknown", Lobable, Fragile , toVelocity 50 ] -- oily, bad grip , idesc = "A flask of oily liquid of a suspect color. Something seems to be moving inside." , ikit = [] } flask1 = flaskTemplate { ifreq = [("common item", 100), ("explosive", 100), ("any vial", 100)] , irarity = [(10, 5)] , ieffects = [ toOrganGood "strengthened" (20 + 1 `d` 5) , toOrganNoTimer "regenerating" , OnSmash (Explode "dense shower") ] , ifeature = [ELabel "of strength renewal brew"] ++ ifeature flaskTemplate } flask2 = flaskTemplate { ifreq = [("common item", 100), ("explosive", 100), ("any vial", 100)] , ieffects = [ toOrganBad "weakened" (20 + 1 `d` 5) , OnSmash (Explode "sparse shower") ] , ifeature = [ELabel "of weakness brew"] ++ ifeature flaskTemplate } flask3 = flaskTemplate { ifreq = [("common item", 100), ("explosive", 100), ("any vial", 100)] , ieffects = [ toOrganGood "protected from melee" (20 + 1 `d` 5) , OnSmash (Explode "melee protective balm") ] , ifeature = [ELabel "of melee protective balm"] ++ ifeature flaskTemplate } flask4 = flaskTemplate { ifreq = [("common item", 100), ("explosive", 100), ("any vial", 100)] , ieffects = [ toOrganGood "protected from ranged" (20 + 1 `d` 5) , OnSmash (Explode "ranged protective balm") ] , ifeature = [ELabel "of ranged protective balm"] ++ ifeature flaskTemplate } flask5 = flaskTemplate { ifreq = [("common item", 100), ("explosive", 100), ("any vial", 100)] , ieffects = [ toOrganBad "defenseless" (20 + 1 `d` 5) , Impress , Detect DetectExit 20 , OnSmash (Explode "PhD defense question") ] , ifeature = [ELabel "of PhD defense questions"] ++ ifeature flaskTemplate } flask6 = flaskTemplate { ifreq = [("common item", 100), ("explosive", 100), ("any vial", 100)] , irarity = [(10, 7)] , ieffects = [ toOrganGood "resolute" (200 + 1 `d` 50) -- long, for scouting and has to recharge , RefillCalm 60 -- not to make it a drawback, via @calmEnough@ , OnSmash (Explode "resolution dust") ] , ifeature = [ELabel "of resolution"] ++ ifeature flaskTemplate } flask7 = flaskTemplate { ifreq = [("common item", 100), ("explosive", 100), ("any vial", 100)] , icount = 1 -- too poweful en masse , ieffects = [ toOrganGood "hasted" (20 + 1 `d` 5) , OnSmash (Explode "haste spray") ] , ifeature = [ELabel "of haste brew"] ++ ifeature flaskTemplate } flask8 = flaskTemplate { ifreq = [("common item", 100), ("explosive", 100), ("any vial", 100)] , irarity = [(1, 12), (10, 2)] , ieffects = [ toOrganBad "slowed" (20 + 1 `d` 5) , toOrganNoTimer "regenerating", toOrganNoTimer "regenerating" -- x2 , RefillCalm 5 , OnSmash (Explode "slowness mist") , OnSmash (Explode "youth sprinkle") ] , ifeature = [ELabel "of lethargy brew"] ++ ifeature flaskTemplate } flask9 = flaskTemplate { ifreq = [("common item", 100), ("explosive", 100), ("any vial", 100)] , ieffects = [ toOrganGood "far-sighted" (40 + 1 `d` 10) , OnSmash (Explode "eye drop") ] , ifeature = [ELabel "of eye drops"] ++ ifeature flaskTemplate } flask10 = flaskTemplate { ifreq = [("common item", 100), ("explosive", 100), ("any vial", 100)] , irarity = [(10, 2)] -- not very useful right now , ieffects = [ toOrganGood "keen-smelling" (40 + 1 `d` 10) , Detect DetectActor 10 , OnSmash (Explode "smelly droplet") ] , ifeature = [ELabel "of smelly concoction"] ++ ifeature flaskTemplate } flask11 = flaskTemplate { ifreq = [("common item", 100), ("explosive", 100), ("any vial", 100)] , irarity = [(10, 2)] -- not very useful right now , ieffects = [ toOrganGood "shiny-eyed" (40 + 1 `d` 10) , OnSmash (Explode "eye shine") ] , ifeature = [ELabel "of cat tears"] ++ ifeature flaskTemplate } flask12 = flaskTemplate { iname = "bottle" , ifreq = [("common item", 100), ("explosive", 100), ("any vial", 100)] , icount = 1 `d` 3 -- the only one sometimes giving away its identity , ieffects = [ toOrganGood "drunk" (20 + 1 `d` 5) , Burn 1, RefillHP 3 , OnSmash (Explode "whiskey spray") ] , ifeature = [ELabel "of whiskey"] ++ ifeature flaskTemplate } flask13 = flaskTemplate { ifreq = [("common item", 100), ("explosive", 100), ("any vial", 100)] , icount = 1 , ieffects = [ toOrganGood "drunk" (20 + 1 `d` 5) , Burn 1, RefillHP 3 , Summon "mobile animal" 1 , OnSmash (Summon "mobile animal" 1) , OnSmash Impress , OnSmash (Explode "waste") ] , ifeature = [ELabel "of bait cocktail"] ++ ifeature flaskTemplate } -- The player has full control over throwing the flask at his party, -- so he can milk the explosion, so it has to be much weaker, so a weak -- healing effect is enough. OTOH, throwing a harmful flask at many enemies -- at once is not easy to arrange, so these explostions can stay powerful. flask14 = flaskTemplate { ifreq = [("common item", 100), ("explosive", 100), ("any vial", 100)] , irarity = [(1, 2), (10, 10)] , ieffects = [ toOrganNoTimer "regenerating", toOrganNoTimer "regenerating" -- x2 , OnSmash (Explode "youth sprinkle") ] , ifeature = [ELabel "of regeneration brew"] ++ ifeature flaskTemplate } flask15 = flaskTemplate { ifreq = [("common item", 100), ("explosive", 100), ("any vial", 100)] , ieffects = [ toOrganNoTimer "poisoned", toOrganNoTimer "poisoned" -- x2 , OnSmash (Explode "poison cloud") ] , ifeature = [ELabel "of poison"] ++ ifeature flaskTemplate } flask16 = flaskTemplate { ifreq = [("common item", 100), ("explosive", 100), ("any vial", 100)] , ieffects = [ toOrganNoTimer "poisoned" , OnSmash (Explode "poison cloud") ] , ifeature = [ELabel "of weak poison"] ++ ifeature flaskTemplate } flask17 = flaskTemplate { ifreq = [("common item", 100), ("explosive", 100), ("any vial", 100)] , irarity = [(10, 3)] , ieffects = [ toOrganNoTimer "slow resistant" , OnSmash (Explode "anti-slow mist") ] , ifeature = [ELabel "of slow resistance"] ++ ifeature flaskTemplate } flask18 = flaskTemplate { ifreq = [("common item", 100), ("explosive", 100), ("any vial", 100)] , irarity = [(10, 3)] , ieffects = [ toOrganNoTimer "poison resistant" , OnSmash (Explode "antidote mist") ] , ifeature = [ELabel "of poison resistance"] ++ ifeature flaskTemplate } flask19 = flaskTemplate { ifreq = [("common item", 100), ("explosive", 100), ("any vial", 100)] , ieffects = [ toOrganBad "blind" (40 + 1 `d` 10) , OnSmash (Explode "iron filing") ] , ifeature = [ELabel "of blindness"] ++ ifeature flaskTemplate } flask20 = flaskTemplate { ifreq = [("common item", 100), ("explosive", 100), ("any vial", 100)] , ieffects = [ toOrganNoTimer "poisoned" , toOrganBad "weakened" (20 + 1 `d` 5) , toOrganBad "defenseless" (20 + 1 `d` 5) , OnSmash (Explode "glass hail") ] -- enough glass to cause that , ifeature = [ELabel "of calamity"] ++ ifeature flaskTemplate } -- Potions are often natural. Appear deeper than most flasks. Various -- configurations of effects. A different class of effects is on scrolls -- and mechanical items. Some are shared. potionTemplate = ItemKind { isymbol = symbolPotion , iname = "potion" , ifreq = [("potion unknown", 1)] , iflavour = zipLiquid brightCol ++ zipPlain brightCol ++ zipFancy brightCol , icount = 1 `dL` 3 , irarity = [(1, 10), (10, 6)] , iverbHit = "splash" , iweight = 200 , idamage = 0 , iaspects = [] , ieffects = [] , ifeature = [ HideAs "potion unknown", Lobable, Fragile , toVelocity 50 ] -- oily, bad grip , idesc = "A vial of bright, frothing concoction. The best that nature has to offer." , ikit = [] } potion1 = potionTemplate { iname = "vial" , ifreq = [("common item", 100), ("potion", 100), ("any vial", 100)] , icount = 3 `dL` 1 -- very useful, despite appearances , ieffects = [ Impress, RefillCalm (-5) , OnSmash ApplyPerfume, OnSmash (Explode "fragrance") ] , ifeature = [ELabel "of rose water"] ++ ifeature potionTemplate } potion2 = potionTemplate { ifreq = [("treasure", 100)] , icount = 1 , irarity = [(5, 8), (10, 8)] , ieffects = [ Impress, RefillCalm (-20) , OnSmash (Explode "pheromone") ] , ifeature = [Unique, ELabel "of Attraction"] ++ [ Lobable, Fragile -- identified , toVelocity 50 ] -- , idesc = "" } potion3 = potionTemplate { ifreq = [("common item", 100), ("potion", 100), ("any vial", 100)] , ieffects = [ RefillHP 5, DropItem 1 maxBound COrgan "poisoned" , OnSmash (Explode "healing mist") ] } potion4 = potionTemplate { ifreq = [("common item", 100), ("potion", 100), ("any vial", 100)] , irarity = [(1, 6), (10, 9)] , ieffects = [ RefillHP 10, DropItem 1 maxBound COrgan "poisoned" , OnSmash (Explode "healing mist 2") ] } potion5 = potionTemplate -- needs to be common to show at least a portion of effects { ifreq = [("common item", 100), ("potion", 100), ("any vial", 100)] , icount = 3 `dL` 1 -- always as many as possible on this level -- without giving away potion identity , irarity = [(1, 10)] , ieffects = [ OneOf [ RefillHP 10, RefillHP 5, Burn 5 , DropItem 1 maxBound COrgan "poisoned" , toOrganGood "strengthened" (20 + 1 `d` 5) ] , OnSmash (OneOf [ Explode "dense shower" , Explode "sparse shower" , Explode "melee protective balm" , Explode "ranged protective balm" , Explode "PhD defense question" ]) ] } potion6 = potionTemplate -- needs to be common to show at least a portion of effects { ifreq = [("common item", 100), ("potion", 100), ("any vial", 100)] , icount = 3 `dL` 1 , irarity = [(10, 8)] , ieffects = [ Impress , OneOf [ RefillCalm (-60) , RefillHP 20, RefillHP 10, Burn 10 , DropItem 1 maxBound COrgan "poisoned" , toOrganGood "hasted" (20 + 1 `d` 5) ] , OnSmash (OneOf [ Explode "healing mist 2" , Explode "wounding mist" , Explode "distressing odor" , Explode "haste spray" , Explode "slowness mist" , Explode "fragrance" , Explode "violent flash" ]) ] } potion7 = potionTemplate { ifreq = [("common item", 100), ("potion", 100), ("any vial", 100)] , ieffects = [ DropItem 1 maxBound COrgan "poisoned" , OnSmash (Explode "antidote mist") ] } potion8 = potionTemplate { iname = "ampoule" -- probably filled with nitroglycerine, but let's -- not mix fantasy with too much technical jargon , ifreq = [("common item", 100), ("potion", 100), ("any vial", 100)] , icount = 3 `dL` 1 , ieffects = [ DropItem 1 maxBound COrgan "condition" , OnSmash (Explode "violent concussion") ] -- not fragmentation nor glass hail, because not enough glass } potion9 = potionTemplate { ifreq = [("treasure", 100)] , icount = 1 , irarity = [(10, 5)] , ieffects = [ RefillHP 60, Impress, RefillCalm (-60) , OnSmash (Explode "healing mist 2") , OnSmash (Explode "pheromone") ] , ifeature = [Unique, ELabel "of Love"] ++ [ Lobable, Fragile -- identified , toVelocity 50 ] -- , idesc = "" } -- * Explosives, with the only effect being @Explode@ fragmentationBomb = ItemKind { isymbol = symbolProjectile , iname = "clay pot" -- clay pot filled with black powder; fragmentation comes from the clay -- shards, so it's not obvious if it's a weapon or just storage method; -- deflagration, not detonation, so large mass and hard container -- required not to burn harmlessly; improvised short fuze , ifreq = [("common item", 100), ("explosive", 200)] , iflavour = zipPlain [Red] , icount = 1 `dL` 4 -- many, because not very intricate , irarity = [(5, 5), (10, 5)] , iverbHit = "thud" , iweight = 3000 -- low velocity due to weight , idamage = 1 `d` 1 -- heavy and hard , iaspects = [] , ieffects = [ Explode "focused fragmentation" , OnSmash (Explode "violent fragmentation") ] , ifeature = [ELabel "of black powder", Lobable, Fragile] , idesc = "The practical application of science." -- given that we now have several kinds of explosives, tell something -- related to 'fragmentation', e.g., mention flying shards , ikit = [] } concussionBomb = fragmentationBomb { iname = "satchel" -- slightly stabilized nitroglycerine in a soft satchel, hence -- no fragmentation, but huge shock wave despite small size and lack -- of strong container to build up pressure; indoors help the shock wave; -- unstable enough that no fuze required , iflavour = zipPlain [Magenta] , iverbHit = "flap" , iweight = 400 , idamage = 0 , ieffects = [ Explode "focused concussion" , OnSmash (Explode "violent concussion") ] , ifeature = [ ELabel "of mining charges", Lobable, Fragile , toVelocity 70 ] -- flappy and so slow , idesc = "" } -- Not flashbang, because powerful bang without fragmentation is harder -- to manufacture (requires an oxidizer and steel canister with holes) -- and because we don't model hearing adequately yet. The bang would also -- paralyze and/or lower the movement skill (out of balance due to ear trauma). flashBomb = fragmentationBomb { iname = "magnesium ribbon" -- filled with magnesium flash powder , iflavour = zipPlain [BrWhite] , iverbHit = "flash" , iweight = 400 , idamage = 0 , ieffects = [Explode "focused flash", OnSmash (Explode "violent flash")] , ifeature = [Lobable, Fragile, toVelocity 70] -- bad shape for throwing , idesc = "" } firecrackerBomb = fragmentationBomb { iname = "roll" -- not fireworks, as they require outdoors , iflavour = zipPlain [BrMagenta] , irarity = [(1, 5), (5, 5)] -- a toy, if deadly , iverbHit = "crack" -- a pun, matches the verb from "ItemKindBlast" , iweight = 1000 , idamage = 0 , ieffects = [Explode "firecracker", OnSmash (Explode "firecracker")] , ifeature = [Lobable, Fragile] , idesc = "String and paper, concealing a deadly surprise." } -- * Non-exploding consumables, not specifically designed for throwing scrollTemplate = ItemKind { isymbol = symbolScroll , iname = "scroll" , ifreq = [("scroll unknown", 1)] , iflavour = zipFancy stdCol ++ zipPlain darkCol -- arcane and old , icount = 1 `dL` 3 , irarity = [(1, 14), (10, 7)] , iverbHit = "thump" , iweight = 50 , idamage = 0 , iaspects = [] , ieffects = [] , ifeature = [ HideAs "scroll unknown" , toVelocity 30 ] -- bad shape, even rolled up , idesc = "Scraps of haphazardly scribbled mysteries from beyond. Is this equation an alchemical recipe? Is this diagram an extradimensional map? Is this formula a secret call sign?" , ikit = [] } scroll1 = scrollTemplate { ifreq = [("treasure", 100)] , icount = 1 , irarity = [(5, 9), (10, 9)] -- mixed blessing, so available early, often , ieffects = [Summon "hero" 1, Summon "mobile animal" (2 + 1 `d` 2)] , ifeature = [Unique, ELabel "of Reckless Beacon"] ++ ifeature scrollTemplate , idesc = "The bright flame and sweet-smelling smoke of this heavily infused scroll should attract natural creatures inhabiting the area, including human survivors, if any." } scroll2 = scrollTemplate { ifreq = [("common item", 100), ("any scroll", 100)] , irarity = [(1, 2)] -- mixed blessing , ieffects = [Detect DetectItem 20, Teleport 20, RefillCalm (-100)] , ifeature = [ELabel "of greed"] ++ ifeature scrollTemplate } scroll3 = scrollTemplate { ifreq = [("common item", 100), ("any scroll", 100)] , irarity = [(1, 4), (10, 2)] , ieffects = [Ascend False] } scroll4 = scrollTemplate -- needs to be common to show at least a portion of effects { ifreq = [("common item", 100), ("any scroll", 100)] , icount = 3 `dL` 1 , irarity = [(1, 14)] , ieffects = [OneOf [ Teleport 5, Paralyze 10, InsertMove 10 , Detect DetectEmbed 12, Detect DetectItem 20 ]] } scroll5 = scrollTemplate -- needs to be common to show at least a portion of effects { ifreq = [("common item", 100), ("any scroll", 100)] , icount = 3 `dL` 1 , irarity = [(10, 11)] , ieffects = [ Impress , OneOf [ Teleport 20, Ascend False, Ascend True , Summon "hero" 1, Summon "mobile animal" $ 1 `d` 2 , Detect DetectAll 40, RefillCalm (-100) , CreateItem CGround "common item" timerNone ] ] } scroll6 = scrollTemplate { ifreq = [("common item", 100), ("any scroll", 100)] , ieffects = [Teleport 5] } scroll7 = scrollTemplate { ifreq = [("common item", 100), ("any scroll", 100)] , ieffects = [Teleport 20] } scroll8 = scrollTemplate { ifreq = [("common item", 100), ("any scroll", 100)] , icount = 1 -- too poweful en masse , irarity = [(10, 4)] , ieffects = [InsertMove $ 1 + 1 `d` 2 + 1 `dL` 2] } scroll9 = scrollTemplate { ifreq = [("common item", 100), ("any scroll", 100)] , icount = 3 `dL` 1 , irarity = [(1, 14)] -- uncommon deep down, where all is known , ieffects = [Composite [Identify, RefillCalm 10]] , ifeature = [ELabel "of scientific explanation"] ++ ifeature scrollTemplate , idesc = "The most pressing existential concerns are met with a deeply satisfying scientific answer." } scroll10 = scrollTemplate { ifreq = [("common item", 100), ("any scroll", 100)] , irarity = [(10, 20)] -- at endgame a crucial item may be missing , ieffects = [Composite [PolyItem, Explode "firecracker"]] , ifeature = [ELabel "of transfiguration"] ++ ifeature scrollTemplate } scroll11 = scrollTemplate { ifreq = [("treasure", 100)] , icount = 1 , irarity = [(5, 8), (10, 8)] , ieffects = [Summon "hero" 1] , ifeature = [Unique, ELabel "of Rescue Proclamation"] ++ ifeature scrollTemplate , idesc = "A survivor is found that enjoys, apparently, complete physiological integrity. If we so wish, we can pronounce him rescued and let him join our team." } scroll12 = scrollTemplate { ifreq = [("common item", 100), ("any scroll", 100)] , irarity = [(1, 9), (10, 4)] , ieffects = [Detect DetectHidden 20] } scroll13 = scrollTemplate { ifreq = [("common item", 100), ("any scroll", 100)] , ieffects = [Detect DetectActor 20] , ifeature = [ELabel "of acute hearing"] ++ ifeature scrollTemplate } -- * Assorted tools jumpingPole = ItemKind { isymbol = symbolWand , iname = "jumping pole" , ifreq = [("common item", 100)] , iflavour = zipPlain [White] , icount = 1 , irarity = [(1, 3)] , iverbHit = "prod" , iweight = 10000 , idamage = 0 , iaspects = [Timeout $ (2 + 1 `d` 2 - 1 `dL` 2) * 5] , ieffects = [Recharging (toOrganGood "hasted" 1)] -- safe for AI, because it speeds up, so when AI applies it -- again and again, it gets its time back and is not stuck; -- in total, the explorations speed is unchanged, -- but it's useful when fleeing in the dark to make distance -- and when initiating combat, so it's OK that AI uses it , ifeature = [Durable] , idesc = "Makes you vulnerable at take-off, but then you are free like a bird." , ikit = [] } sharpeningTool = ItemKind { isymbol = symbolTool , iname = "whetstone" , ifreq = [("common item", 100)] , iflavour = zipPlain [Blue] , icount = 1 , irarity = [(10, 10)] , iverbHit = "smack" , iweight = 400 , idamage = 0 , iaspects = [AddHurtMelee $ (1 `dL` 5) * 5] , ieffects = [] , ifeature = [Equipable, EqpSlot EqpSlotAddHurtMelee] , 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 = symbolFood , iname = "pupil" , ifreq = [("common item", 30)] -- spooky and wierd, so rare , iflavour = zipPlain [Red] , icount = 1 , irarity = [(1, 1)] , iverbHit = "gaze at" , iweight = 100 , idamage = 0 , iaspects = [ AddSight 10, AddMaxCalm 30, AddShine 2 , Timeout $ 1 + 1 `d` 2 ] , ieffects = [ Recharging (toOrganNoTimer "poisoned") , Recharging (Summon "mobile monster" 1) ] , ifeature = [Periodic] , idesc = "A slimy, dilated green pupil torn out from some giant eye. Clear and focused, as if still alive." , ikit = [] } motionScanner = ItemKind { isymbol = symbolTool , iname = "draft detector" , ifreq = [("common item", 100), ("add nocto 1", 20)] , iflavour = zipPlain [BrRed] , icount = 1 , irarity = [(5, 2)] , iverbHit = "jingle" , iweight = 300 , idamage = 0 , iaspects = [ AddNocto 1 , AddArmorMelee (-10 + 1 `dL` 5) , AddArmorRanged (-10 + 1 `dL` 5) ] , ieffects = [] , ifeature = [Equipable, EqpSlot EqpSlotMiscBonus] , idesc = "A silk flag with a bell for detecting sudden draft changes. May indicate a nearby corridor crossing or a fast enemy approaching in the dark. Is also very noisy." , ikit = [] } -- * Periodic jewelry gorget = necklaceTemplate { iname = "Old Gorget" , ifreq = [("common item", 25), ("treasure", 25)] , iflavour = zipFancy [BrCyan] -- looks exactly the same as on of necklaces, -- but it's OK, it's an artifact , irarity = [(4, 3), (10, 3)] -- weak, shallow , iaspects = [ Timeout $ (1 `d` 2) * 2 , AddArmorMelee 3 , AddArmorRanged 2 ] , ieffects = [Recharging (RefillCalm 1)] , ifeature = [Unique, Durable, EqpSlot EqpSlotMiscBonus] ++ ifeature necklaceTemplate , 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." } -- Not idenfified, because id by use, e.g., via periodic activations. Fun. necklaceTemplate = ItemKind { isymbol = symbolNecklace , iname = "necklace" , ifreq = [("necklace unknown", 1)] , iflavour = zipFancy stdCol ++ zipPlain brightCol , icount = 1 , irarity = [(10, 2)] , iverbHit = "whip" , iweight = 30 , idamage = 0 , iaspects = [Timeout 1] -- fake, but won't be displayed , ieffects = [] , ifeature = [ Periodic, HideAs "necklace unknown", Precious, Equipable , 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 = necklaceTemplate { ifreq = [("treasure", 100), ("any jewelry", 100)] , iaspects = [Timeout $ (1 `d` 2) * 20] , ieffects = [Recharging (RefillHP 1)] ++ ieffects necklaceTemplate , ifeature = [Unique, ELabel "of Aromata", Durable, EqpSlot EqpSlotMiscBonus] ++ ifeature necklaceTemplate , idesc = "A cord of freshly dried herbs and healing berries." } necklace2 = necklaceTemplate { ifreq = [("treasure", 100), ("any jewelry", 100)] -- too nasty to call it just a "common item" , iaspects = [Timeout 30] , ieffects = [ Recharging (Summon "mobile animal" $ 1 `d` 2) , Recharging (Explode "waste") , Recharging Impress , Recharging (DropItem 1 maxBound COrgan "condition") ] ++ ieffects necklaceTemplate , ifeature = [Unique, ELabel "of Live Bait", Durable] ++ ifeature necklaceTemplate -- , idesc = "" } necklace3 = necklaceTemplate { ifreq = [("common item", 100), ("any jewelry", 100)] , iaspects = [Timeout $ (1 `d` 2) * 20] , ieffects = [ Recharging (Detect DetectActor 10) , Recharging (RefillCalm (-20)) ] ++ ieffects necklaceTemplate , ifeature = [ELabel "of fearful listening"] ++ ifeature necklaceTemplate } necklace4 = necklaceTemplate { ifreq = [("common item", 100), ("any jewelry", 100)] , iaspects = [Timeout $ (3 + 1 `d` 3 - 1 `dL` 3) * 2] , ieffects = [Recharging (Teleport $ 3 `d` 2)] ++ ieffects necklaceTemplate } necklace5 = necklaceTemplate { ifreq = [("common item", 100), ("any jewelry", 100)] , iaspects = [Timeout $ (7 - 1 `dL` 5) * 10] , ieffects = [ Recharging (Teleport $ 14 + 3 `d` 3) , Recharging (Detect DetectExit 20) , Recharging (RefillHP (-2)) ] -- prevent micromanagement ++ ieffects necklaceTemplate , ifeature = [ELabel "of escape"] ++ ifeature necklaceTemplate } necklace6 = necklaceTemplate { ifreq = [("common item", 100), ("any jewelry", 100)] , iaspects = [Timeout $ 1 + (1 `d` 3) * 2] , ieffects = [Recharging (PushActor (ThrowMod 100 50))] -- 1 step, slow -- the @50@ is only for the case of very light actor, etc. ++ ieffects necklaceTemplate } necklace7 = necklaceTemplate { ifreq = [("treasure", 100), ("any jewelry", 100)] , iaspects = [AddMaxHP 15, AddArmorMelee 20, AddArmorRanged 10, Timeout 4] , ieffects = [ Recharging (InsertMove $ 1 `d` 3) -- unpredictable , Recharging (RefillCalm (-1)) -- fake "hears something" :) , Recharging (RefillHP (-1)) ] ++ ieffects necklaceTemplate , ifeature = [Unique, ELabel "of Overdrive", Durable, EqpSlot EqpSlotAddSpeed] ++ ifeature necklaceTemplate -- , idesc = "" } necklace8 = necklaceTemplate { ifreq = [("common item", 100), ("any jewelry", 100)] , iaspects = [Timeout $ (1 + 1 `d` 3) * 5] , ieffects = [Recharging $ Explode "spark"] ++ ieffects necklaceTemplate } necklace9 = necklaceTemplate { ifreq = [("common item", 100), ("any jewelry", 100)] , iaspects = [Timeout $ (1 + 1 `d` 3) * 5] , ieffects = [Recharging $ Explode "fragrance"] ++ ieffects necklaceTemplate } -- * Non-periodic jewelry imageItensifier = ItemKind { isymbol = symbolRing , iname = "light cone" , ifreq = [("treasure", 100), ("add nocto 1", 80)] , iflavour = zipFancy [BrYellow] , icount = 1 , irarity = [(5, 2)] , iverbHit = "bang" , iweight = 500 , idamage = 0 , iaspects = [AddNocto 1, AddSight (-1), AddArmorMelee $ (1 `dL` 3) * 3] , ieffects = [] , ifeature = [Precious, Durable, Equipable, EqpSlot EqpSlotMiscBonus] , idesc = "Contraption of lenses and mirrors on a polished brass headband for capturing and strengthening light in dark environment. Hampers vision in daylight. Stackable." , ikit = [] } sightSharpening = ringTemplate -- small and round, so mistaken for a ring { iname = "sharp monocle" , ifreq = [("treasure", 10), ("add sight", 1)] -- it's has to be very rare, because it's powerful and not unique, -- and also because it looks exactly as one of necklaces, so it would -- be misleading when seen on the map , irarity = [(7, 1), (10, 5)] -- low @ifreq@ , iweight = 50 -- heavier that it looks, due to glass , iaspects = [AddSight $ 1 + 1 `d` 2, AddHurtMelee $ (1 `d` 2) * 3] , ifeature = [EqpSlot EqpSlotAddSight] ++ ifeature ringTemplate , idesc = "Lets you better focus your weaker eye." } -- Don't add standard effects to rings, because they go in and out -- of eqp and so activating them would require UI tedium: looking for -- them in eqp and inv or even activating a wrong item by mistake. -- -- By general mechanisms, due to not having effects that could identify -- them by observing the effect, rings are identified on pickup. -- That's unlike necklaces, which provide the fun of id-by-use, because they -- have effects and when the effects are triggered, they get identified. ringTemplate = ItemKind { isymbol = symbolRing , iname = "ring" , ifreq = [("ring unknown", 1)] , iflavour = zipPlain stdCol ++ zipFancy darkCol , icount = 1 , irarity = [(10, 1)] -- the default very low , iverbHit = "knock" , iweight = 15 , idamage = 0 , iaspects = [] , ieffects = [] , ifeature = [HideAs "ring unknown", Precious, Equipable] , idesc = "It looks like an ordinary object, but it's in fact a generator of exceptional effects: adding to some of your natural qualities and subtracting from others." , ikit = [] } ring1 = ringTemplate { ifreq = [("common item", 100), ("any jewelry", 100)] , irarity = [(10, 4)] , iaspects = [AddSpeed $ 1 `d` 3, AddMaxHP (-15)] , ieffects = [OnSmash (Explode "distortion")] -- high power , ifeature = [EqpSlot EqpSlotAddSpeed] ++ ifeature ringTemplate } ring2 = ringTemplate { ifreq = [("treasure", 100), ("any jewelry", 100)] , irarity = [(10, 2)] , iaspects = [AddSpeed $ (1 `d` 2) * 3, AddMaxCalm (-40), AddMaxHP (-20)] , ieffects = [OnSmash (Explode "distortion")] -- high power , ifeature = [Unique, ELabel "of Rush", Durable, EqpSlot EqpSlotAddSpeed] ++ ifeature ringTemplate -- , idesc = "" } ring3 = ringTemplate { ifreq = [("common item", 100), ("any jewelry", 100)] , irarity = [(10, 11)] , iaspects = [ AddMaxHP $ 10 + (1 `dL` 5) * 2 , AddMaxCalm $ -20 + (1 `dL` 5) * 2 ] , ifeature = [EqpSlot EqpSlotAddMaxHP] ++ ifeature ringTemplate } ring4 = ringTemplate { ifreq = [("common item", 100), ("any jewelry", 100)] , irarity = [(5, 1), (10, 14)] -- needed after other rings drop Calm , iaspects = [AddMaxCalm $ 25 + (1 `dL` 4) * 5] , ifeature = [EqpSlot EqpSlotMiscBonus] ++ ifeature ringTemplate , idesc = "Cold, solid to the touch, perfectly round, engraved with solemn, strangely comforting, worn out words." } ring5 = ringTemplate { ifreq = [("common item", 100), ("any jewelry", 100)] , irarity = [(3, 3), (10, 6)] , iaspects = [ AddHurtMelee $ (2 + 1 `d` 2 + (1 `dL` 2) * 2 ) * 3 , AddMaxHP $ (-2 - (1 `d` 2) + (1 `dL` 2) * 2) * 3 ] -- !!! , ifeature = [EqpSlot EqpSlotAddHurtMelee] ++ ifeature ringTemplate } ring6 = ringTemplate -- by the time it's found, probably no space in eqp { ifreq = [("common item", 100), ("any jewelry", 100)] , irarity = [(5, 0), (10, 4)] , iaspects = [AddShine $ 1 `d` 2] , ifeature = [EqpSlot EqpSlotLightSource] ++ ifeature ringTemplate , idesc = "A sturdy ring with a large, shining stone." } ring7 = ringTemplate { ifreq = [("common item", 10), ("ring of opportunity sniper", 1) ] , irarity = [(10, 5)] -- low @ifreq@ , iaspects = [AddAbility AbProject 8] , ieffects = [OnSmash (Explode "distortion")] -- high power , ifeature = [ELabel "of opportunity sniper", EqpSlot EqpSlotAbProject] ++ ifeature ringTemplate } ring8 = ringTemplate { ifreq = [("common item", 1), ("ring of opportunity grenadier", 1) ] , irarity = [(1, 1)] , iaspects = [AddAbility AbProject 11] , ieffects = [OnSmash (Explode "distortion")] -- high power , ifeature = [ELabel "of opportunity grenadier", EqpSlot EqpSlotAbProject] ++ ifeature ringTemplate } -- * Armor armorLeather = ItemKind { isymbol = symbolTorsoArmor , iname = "leather armor" , ifreq = [("common item", 100), ("torso armor", 1)] , iflavour = zipPlain [Brown] , icount = 1 , irarity = [(1, 9), (10, 3)] , iverbHit = "thud" , iweight = 7000 , idamage = 0 , iaspects = [ AddHurtMelee (-2) , AddArmorMelee $ (2 + 1 `dL` 4) * 5 , AddArmorRanged $ (1 + 1 `dL` 2) * 3 ] , ieffects = [] , ifeature = [Durable, Equipable, EqpSlot EqpSlotAddArmorMelee] , idesc = "A stiff jacket formed from leather boiled in bee wax, padded linen and horse hair. Protects from anything that is not too sharp. Smells much better than the rest of your garment." , ikit = [] } armorMail = armorLeather { iname = "mail armor" , ifreq = [("common item", 100), ("torso armor", 1), ("armor ranged", 50) ] , iflavour = zipPlain [Cyan] , irarity = [(6, 9), (10, 3)] , iweight = 12000 , idamage = 0 , iaspects = [ AddHurtMelee (-3) , AddArmorMelee $ (2 + 1 `dL` 4) * 5 , AddArmorRanged $ (4 + 1 `dL` 2) * 3 ] , ieffects = [] , ifeature = [Durable, Equipable, EqpSlot EqpSlotAddArmorRanged] , idesc = "A long shirt woven from iron rings that are hard to pierce through. Discourages foes from attacking your torso, making it harder for them to hit you." } gloveFencing = ItemKind { isymbol = symbolMiscArmor , iname = "leather glove" , ifreq = [("common item", 100), ("misc armor", 1), ("armor ranged", 50)] , iflavour = zipPlain [BrYellow] , icount = 1 , irarity = [(5, 9), (10, 9)] , iverbHit = "flap" , iweight = 100 , idamage = 1 `d` 1 , iaspects = [ AddHurtMelee $ (2 + 1 `d` 2 + 1 `dL` 2) * 3 , AddArmorRanged $ (1 `dL` 2) * 3 ] , ieffects = [] , ifeature = [ toVelocity 50 -- flaps and flutters , Durable, Equipable, EqpSlot EqpSlotAddHurtMelee ] , 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" , ifreq = [("common item", 100), ("misc armor", 1)] , iflavour = zipPlain [BrCyan] , irarity = [(1, 9), (10, 3)] , iweight = 300 , idamage = 2 `d` 1 , iaspects = [AddArmorMelee $ (1 + 1 `dL` 4) * 5] , ifeature = [ toVelocity 50 -- flaps and flutters , Durable, Equipable, EqpSlot EqpSlotAddArmorMelee ] , idesc = "Long leather gauntlet covered in overlapping steel plates." } gloveJousting = gloveFencing { iname = "Tournament Gauntlet" , ifreq = [("common item", 100), ("misc armor", 1)] , iflavour = zipFancy [BrRed] , irarity = [(1, 3), (10, 3)] , iweight = 3000 , idamage = 3 `d` 1 , iaspects = [ AddHurtMelee $ (-7 + 1 `dL` 5) * 3 , AddArmorMelee $ (2 + 1 `d` 2 + 1 `dL` 2) * 5 , AddArmorRanged $ (1 + 1 `dL` 2) * 3 ] -- very random on purpose and can even be good on occasion , ifeature = [ toVelocity 50 -- flaps and flutters , Unique, Durable, Equipable, EqpSlot EqpSlotAddArmorMelee ] , idesc = "Rigid, steel, jousting handgear. If only you had a lance. And a horse to carry it all." } -- * Shields -- Shield doesn't protect against ranged attacks to prevent -- micromanagement: walking with shield, melee without. -- Note that AI will pick them up but never wear and will use them at most -- as a way to push itself (but they won't recharge, not being in eqp). -- Being @Meleeable@ they will not be use as weapons either. -- This is OK, using shields smartly is totally beyond AI. buckler = ItemKind { isymbol = symbolShield , iname = "buckler" , ifreq = [("common item", 100)] , iflavour = zipPlain [Blue] , icount = 1 , irarity = [(4, 5)] , iverbHit = "bash" , iweight = 2000 , idamage = 2 `d` 1 , iaspects = [ AddArmorMelee 40 -- not enough to compensate; won't be in eqp , AddHurtMelee (-30) -- too harmful; won't be wielded as weapon , Timeout $ (3 + 1 `d` 3 - 1 `dL` 3) * 2 ] , ieffects = [Recharging (PushActor (ThrowMod 100 50))] -- 1 step, slow , ifeature = [ toVelocity 50 -- unwieldy to throw , MinorEffects, Durable, Meleeable , EqpSlot EqpSlotAddArmorMelee ] , 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, 4)] -- the stronger variants add to total probability , iflavour = zipPlain [Green] , iweight = 4000 , idamage = 4 `d` 1 , iaspects = [ AddArmorMelee 80 -- not enough to compensate; won't be in eqp , AddHurtMelee (-70) -- too harmful; won't be wielded as weapon , Timeout $ (3 + 1 `d` 3 - 1 `dL` 3) * 4 ] , ieffects = [Recharging (PushActor (ThrowMod 400 25))] -- 1 step, fast , ifeature = [ toVelocity 50 -- unwieldy to throw , MinorEffects, Durable, Meleeable , EqpSlot EqpSlotAddArmorMelee ] , idesc = "Large and unwieldy. Absorbs a percentage of melee damage, both dealt and sustained. Too heavy to intercept projectiles with." } shield2 = shield { ifreq = [("common item", 3 * 3)] -- very low base rarity , iweight = 5000 , idamage = 8 `d` 1 -- , idesc = "" e.g., "this kind has a spike protruding from the center" } shield3 = shield { ifreq = [("common item", 1 * 3)] -- very low base rarity , iweight = 6000 , idamage = 12 `d` 1 -- , idesc = "" } -- * Weapons dagger = ItemKind { isymbol = symbolEdged , iname = "dagger" , ifreq = [("common item", 100), ("starting weapon", 100)] , iflavour = zipPlain [BrCyan] , icount = 1 , irarity = [(1, 40), (3, 1)] , iverbHit = "stab" , iweight = 800 , idamage = 6 `d` 1 , iaspects = [ AddHurtMelee $ (-1 + 1 `d` 2 + 1 `dL` 2) * 3 , AddArmorMelee $ (1 `d` 2) * 5 ] -- very common, so don't make too random , ieffects = [] , ifeature = [ toVelocity 40 -- ensuring it hits with the tip costs speed , Durable, Meleeable, EqpSlot EqpSlotWeapon ] , 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, 5), (10, 3)] -- Here timeout has to be small, if the player is to 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. -- Here the timeout is either very small or very large, randomly. -- In the latter case the weapon is best swapped for a stronger one -- later on in the game, but provides some variety at the start. , iaspects = iaspects dagger ++ [Timeout $ (1 `d` 2) * 20 - 16] , ieffects = ieffects dagger ++ [ Recharging DropBestWeapon, Recharging $ RefillCalm (-3) ] , ifeature = [Unique] ++ ifeature dagger , idesc = "A double dagger that a focused fencer can use to catch and twist away an opponent's blade occasionally." } hammer = ItemKind { isymbol = symbolHafted , iname = "war hammer" , ifreq = [ ("common item", 100), ("starting weapon", 100) , ("hammer unknown", 1) ] , iflavour = zipFancy [BrMagenta] -- avoid "pink" , icount = 1 , irarity = [(5, 20), (8, 1)] , iverbHit = "club" , iweight = 1600 , idamage = 8 `d` 1 -- we are lying about the dice here, but the dungeon -- is too small and the extra-dice hammers too rare -- to subdivide this identification class by dice , iaspects = [AddHurtMelee $ (-1 + 1 `d` 2 + 1 `dL` 2) * 3] , ieffects = [] , ifeature = [ HideAs "hammer unknown" , toVelocity 40 -- ensuring it hits with the tip costs speed , Durable, Meleeable, EqpSlot EqpSlotWeapon ] , idesc = "It may not cause extensive wounds, but neither does it harmlessly glance off heavy armour as blades and polearms tend to. There are so many shapes and types, some looking more like tools than weapons, that at a glance you can't tell what a particular specimen does." , ikit = [] } hammer2 = hammer { ifreq = [("common item", 3), ("starting weapon", 1)] , iweight = 2000 , idamage = 12 `d` 1 , idesc = "Upon closer inspection, this hammer turns out particularly deadly, with one thick and sturdy and two long and sharp points." } hammer3 = hammer { ifreq = [("common item", 1)] , iweight = 2400 , idamage = 16 `d` 1 , idesc = "This hammer sports a long metal handle that increases durability and momentum of the sharpened head's swing." } hammerParalyze = hammer { iname = "Concussion Hammer" , ifreq = [("treasure", 20)] , irarity = [(5, 1), (10, 6)] , idamage = 8 `d` 1 , iaspects = iaspects hammer ++ [Timeout 7] , ieffects = ieffects hammer ++ [Recharging $ Paralyze 10] , ifeature = [Unique] ++ ifeature hammer , idesc = "A huge shapeless lump of steel on a long pole. Nobody remains standing after this hammer connects." } hammerSpark = hammer { iname = "Grand Smithhammer" , ifreq = [("treasure", 20)] , irarity = [(5, 1), (10, 6)] , idamage = 12 `d` 1 , iaspects = iaspects hammer ++ [AddShine 3, Timeout 10] , ieffects = ieffects hammer ++ [Recharging $ Explode "spark"] -- we can't use a focused explosion, because it would harm the hammer -- wielder as well, unlike this one , ifeature = [Unique] ++ ifeature hammer , idesc = "Smiths of old wielded this hammer and its sparks christened many a potent blade." } sword = ItemKind { isymbol = symbolEdged , iname = "sword" , ifreq = [("common item", 100), ("starting weapon", 10)] , iflavour = zipPlain [BrBlue] , icount = 1 , irarity = [(4, 1), (5, 15)] , iverbHit = "slash" , iweight = 2000 , idamage = 10 `d` 1 , iaspects = [] , ieffects = [] , ifeature = [ toVelocity 40 -- ensuring it hits with the tip costs speed , Durable, Meleeable, EqpSlot EqpSlotWeapon ] , 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, 6)] , iaspects = [Timeout $ (1 `d` 2) * 40 - 30] , ieffects = ieffects sword ++ [Recharging Impress] , ifeature = [Unique] ++ ifeature sword , 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, 6)] , iaspects = [Timeout 10] , ieffects = ieffects sword ++ [ Recharging $ DropItem 1 maxBound COrgan "condition" , Recharging $ RefillCalm (-10) ] , ifeature = [Unique] ++ ifeature sword , idesc = "Cold, thin blade that pierces deeply and sends its victim into abrupt, sobering shock." } halberd = ItemKind { isymbol = symbolPolearm , iname = "war scythe" , ifreq = [("common item", 100), ("starting weapon", 20)] , iflavour = zipPlain [BrYellow] , icount = 1 , irarity = [(7, 1), (9, 15)] , iverbHit = "impale" , iweight = 3000 , idamage = 12 `d` 1 , iaspects = [ AddHurtMelee (-20) -- useless against armor at game start , AddArmorMelee $ (1 `dL` 4) * 5 ] , ieffects = [] , ifeature = [ toVelocity 20 -- not balanced , Durable, Meleeable, EqpSlot EqpSlotWeapon ] , idesc = "An improvised but deadly weapon made of a blade from a scythe attached to a long pole." , ikit = [] } halberd2 = halberd { ifreq = [("common item", 3 * 2), ("starting weapon", 1)] , iweight = 4000 , idamage = 18 `d` 1 -- , idesc = "" } halberd3 = halberd { ifreq = [("common item", 1 * 2)] -- compensating for low base rarity , iweight = 5000 , idamage = 24 `d` 1 -- , idesc = "" } halberdPushActor = halberd { iname = "Swiss Halberd" , ifreq = [("treasure", 20)] , irarity = [(8, 1), (10, 15)] , idamage = 12 `d` 1 , iaspects = iaspects halberd ++ [Timeout $ (1 `d` 2) * 10] , ieffects = ieffects halberd ++ [Recharging (PushActor (ThrowMod 400 25))] -- 1 step , ifeature = [Unique] ++ ifeature halberd , idesc = "A versatile polearm, with great reach and leverage. Foes are held at a distance." } -- * Wands wandTemplate = ItemKind { isymbol = symbolWand , iname = "wand" , ifreq = [("wand unknown", 1)] , iflavour = zipFancy brightCol , icount = 1 , irarity = [] , iverbHit = "club" , iweight = 300 , idamage = 0 , iaspects = [AddShine 1, AddSpeed (-1)] -- pulsing with power, distracts , ieffects = [] , ifeature = [ HideAs "wand unknown", Durable , toVelocity 125 ] -- magic , idesc = "Buzzing with dazzling light that shines even through appendages that handle it." -- will have math flavour , ikit = [] } wand1 = wandTemplate { ifreq = [] , ieffects = [] -- will be: emit a cone of sound shrapnel that makes enemy cover his ears and so drop '|' and '{' } -- * Treasure gemTemplate = ItemKind { isymbol = symbolGold , iname = "gem" , ifreq = [("gem unknown", 1), ("valuable", 100)] , iflavour = zipPlain $ delete BrYellow brightCol -- natural, so not fancy , icount = 1 , irarity = [(3, 0), (10, 24)] , iverbHit = "tap" , iweight = 50 , idamage = 0 , iaspects = [] , ieffects = [] , ifeature = [HideAs "gem unknown", 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 = gemTemplate { ifreq = [ ("treasure", 100), ("gem", 100), ("any jewelry", 100) , ("valuable", 100) ] , irarity = [(3, 0), (10, 24)] , iaspects = [AddShine 1, AddSpeed (-1)] -- reflects strongly, distracts; so it glows in the dark, -- is visible on dark floor, but not too tempting to wear , ieffects = [RefillCalm (-1)] -- minor effect to ensure no id-on-pickup } gem2 = gem1 { ifreq = [ ("treasure", 100), ("gem", 100), ("any jewelry", 100) , ("valuable", 100) ] , irarity = [(5, 0), (10, 28)] } gem3 = gem1 { ifreq = [ ("treasure", 100), ("gem", 100), ("any jewelry", 100) , ("valuable", 100) ] , irarity = [(7, 0), (10, 32)] } gem4 = gem1 { ifreq = [ ("treasure", 100), ("gem", 100), ("any jewelry", 100) , ("valuable", 100) ] , irarity = [(9, 0), (10, 100)] } gem5 = gem1 { isymbol = symbolSpecial , iname = "elixir" , ifreq = [ ("treasure", 100), ("gem", 25), ("any jewelry", 25) , ("valuable", 100) ] , iflavour = zipPlain [BrYellow] , irarity = [(1, 40), (10, 40)] , ieffects = [RefillCalm 10, RefillHP 40] , ifeature = [ELabel "of youth", Precious] -- not hidden , 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." } currencyTemplate = ItemKind { isymbol = symbolGold , iname = "gold piece" , ifreq = [("currency unknown", 1), ("valuable", 1)] , iflavour = zipPlain [BrYellow] , icount = 10 + 1 `d` 20 + 1 `dL` 20 , irarity = [(1, 25), (10, 10)] , iverbHit = "tap" , iweight = 31 , idamage = 0 , iaspects = [] , ieffects = [] , ifeature = [HideAs "currency unknown", Precious] , idesc = "Reliably valuable in every civilized plane of existence." , ikit = [] } currency = currencyTemplate { ifreq = [("treasure", 100), ("currency", 100), ("valuable", 1)] , iaspects = [AddShine 1, AddSpeed (-1)] , ieffects = [RefillCalm (-1)] } LambdaHack-0.8.3.0/GameDefinition/Content/ItemKindEmbed.hs0000644000000000000000000002402113315545734021317 0ustar0000000000000000-- | Definitions of items embedded in map tiles. module Content.ItemKindEmbed ( embeds ) where import Prelude () import Game.LambdaHack.Common.Prelude import Game.LambdaHack.Common.Color import Game.LambdaHack.Common.Dice import Game.LambdaHack.Common.Flavour import Game.LambdaHack.Common.ItemAspect (Aspect (..)) import Game.LambdaHack.Common.Misc import Game.LambdaHack.Content.ItemKind embeds :: [ItemKind] embeds = [scratchOnWall, obscenePictogram, subtleFresco, treasureCache, treasureCacheTrap, signboardExit, signboardEmbed, fireSmall, fireBig, frost, rubble, doorwayTrapTemplate, doorwayTrap1, doorwayTrap2, doorwayTrap3, stairsUp, stairsDown, escape, staircaseTrapUp, staircaseTrapDown, pulpit] scratchOnWall, obscenePictogram, subtleFresco, treasureCache, treasureCacheTrap, signboardExit, signboardEmbed, fireSmall, fireBig, frost, rubble, doorwayTrapTemplate, doorwayTrap1, doorwayTrap2, doorwayTrap3, stairsUp, stairsDown, escape, staircaseTrapUp, staircaseTrapDown, pulpit :: ItemKind -- Make sure very few walls are substantially useful, e.g., caches, -- and none that are secret. Otherwise the player will spend a lot of time -- bumping walls, which is boring compare to fights or dialogues -- and ever worse, the player will bump all secret walls, wasting time -- and foregoing the fun of guessing how to find entrance to a disjoint part -- of the level by bumping the least number of secret walls. scratchOnWall = ItemKind { isymbol = '?' , iname = "claw mark" , ifreq = [("scratch on wall", 1)] , iflavour = zipPlain [BrBlack] , icount = 1 , irarity = [(1, 1)] , iverbHit = "scratch" , iweight = 1000 , idamage = 0 , iaspects = [] , ieffects = [ Temporary "start making sense of the scratches" , Detect DetectHidden 3 ] , ifeature = [Durable] , idesc = "A seemingly random series of scratches, carved deep into the wall." , ikit = [] } obscenePictogram = ItemKind { isymbol = '*' , iname = "obscene pictogram" , ifreq = [("obscene pictogram", 1)] , iflavour = zipPlain [BrMagenta] , icount = 1 , irarity = [(1, 1)] , iverbHit = "infuriate" , iweight = 1000 , idamage = 0 , iaspects = [Timeout 7] , ieffects = [ Recharging $ Temporary "enter destructive rage at the sight of an obscene pictogram" , Recharging $ RefillCalm (-20) , Recharging $ OneOf [ toOrganGood "strengthened" (3 + 1 `d` 2) , CreateItem CInv "sandstone rock" timerNone ] ] , ifeature = [Durable] , idesc = "It's not even anatomically possible." , ikit = [] } subtleFresco = ItemKind { isymbol = '*' , iname = "subtle fresco" , ifreq = [("subtle fresco", 1)] , iflavour = zipPlain [BrGreen] , icount = 1 , irarity = [(1, 1)] , iverbHit = "sooth" , iweight = 1000 , idamage = 0 , iaspects = [Timeout 7] , ieffects = [ Temporary "feel refreshed by the subtle fresco" , RefillCalm 2 , Recharging $ toOrganGood "far-sighted" (3 + 1 `d` 2) , Recharging $ toOrganGood "keen-smelling" (3 + 1 `d` 2) ] , ifeature = [Durable] , idesc = "Expensive yet tasteful." , ikit = [] } treasureCache = stairsUp { isymbol = 'O' , iname = "treasure cache" , ifreq = [("treasure cache", 1)] , iflavour = zipPlain [BrBlue] , ieffects = [CreateItem CGround "common item" timerNone] , idesc = "Glittering gold, just waiting to be taken." } treasureCacheTrap = ItemKind { isymbol = '^' , iname = "cache trap" , ifreq = [("treasure cache trap", 1)] , iflavour = zipPlain [Red] , icount = 1 , irarity = [(1, 1)] , iverbHit = "taint" , iweight = 1000 , idamage = 0 , iaspects = [] , ieffects = [OneOf [ toOrganBad "blind" (40 + 1 `d` 10) , RefillCalm (-99) , Explode "focused concussion" , RefillCalm (-1), RefillCalm (-1), RefillCalm (-1) , RefillCalm (-1), RefillCalm (-1), RefillCalm (-1) , RefillCalm (-1) ]] , ifeature = [] -- not Durable, springs at most once , idesc = "It's a trap!" , ikit = [] } signboardExit = ItemKind { isymbol = '?' , iname = "inscription" , ifreq = [("signboard", 80)] , iflavour = zipPlain [BrMagenta] , icount = 1 , irarity = [(1, 1)] , iverbHit = "whack" , iweight = 10000 , idamage = 0 , iaspects = [] , ieffects = [Detect DetectExit 100] , ifeature = [Durable] , idesc = "Crude big arrows hastily carved by unknown hands." , ikit = [] } signboardEmbed = signboardExit { iname = "notice" , ifreq = [("signboard", 20)] , ieffects = [Detect DetectEmbed 12] , idesc = "The battered poster is untitled and unsigned." } fireSmall = ItemKind { isymbol = '%' , iname = "small fire" , ifreq = [("small fire", 1)] , iflavour = zipPlain [BrRed] , icount = 1 , irarity = [(1, 1)] , iverbHit = "burn" , iweight = 10000 , idamage = 0 , iaspects = [] , ieffects = [Burn 1, Explode "single spark"] , ifeature = [Durable] , idesc = "A few small logs, burning brightly." , ikit = [] } fireBig = fireSmall { isymbol = 'O' , iname = "big fire" , ifreq = [("big fire", 1)] , ieffects = [ Burn 2, Explode "spark" , CreateItem CInv "wooden torch" timerNone ] , ifeature = [Durable] , idesc = "Glowing with light and warmth." , ikit = [] } frost = ItemKind { isymbol = '^' , iname = "frost" , ifreq = [("frost", 1)] , iflavour = zipPlain [BrBlue] , icount = 1 , irarity = [(1, 1)] , iverbHit = "burn" , iweight = 10000 , idamage = 0 , iaspects = [] , ieffects = [ Burn 1 -- sensory ambiguity between hot and cold , RefillCalm 20 -- cold reason , PushActor (ThrowMod 100 50) ] -- slippery ice, 1 step, slow , ifeature = [Durable] , idesc = "Intricate patterns of shining ice." , ikit = [] } rubble = ItemKind { isymbol = '&' , iname = "rubble" , ifreq = [("rubble", 1)] , iflavour = zipPlain [BrYellow] , icount = 1 , irarity = [(1, 1)] , iverbHit = "bury" , iweight = 100000 , idamage = 0 , iaspects = [] , ieffects = [OneOf [ Explode "focused glass hail" , Summon "animal" $ 1 `dL` 2 , toOrganNoTimer "poisoned" , CreateItem CGround "common item" timerNone , RefillCalm (-1), RefillCalm (-1), RefillCalm (-1) , RefillCalm (-1), RefillCalm (-1), RefillCalm (-1) ]] , ifeature = [Durable] , idesc = "Broken chunks of rock and glass." , ikit = [] } doorwayTrapTemplate = ItemKind { isymbol = '+' , iname = "doorway trap" , ifreq = [("doorway trap unknown", 1)] , iflavour = zipPlain brightCol , icount = 1 , irarity = [(1, 1)] , iverbHit = "cripple" , iweight = 10000 , idamage = 0 , iaspects = [] , ieffects = [] , ifeature = [HideAs "doorway trap unknown"] -- not Durable, springs at most once , idesc = "Just turn the handle..." , ikit = [] } doorwayTrap1 = doorwayTrapTemplate { ifreq = [("doorway trap", 50)] , ieffects = [toOrganBad "blind" $ (1 `dL` 4) * 10] -- , idesc = "" } doorwayTrap2 = doorwayTrapTemplate { ifreq = [("doorway trap", 25)] , ieffects = [toOrganBad "slowed" $ (1 `dL` 4) * 10] -- , idesc = "" } doorwayTrap3 = doorwayTrapTemplate { ifreq = [("doorway trap", 25)] , ieffects = [toOrganBad "weakened" $ (1 `dL` 4) * 10 ] -- , idesc = "" } stairsUp = ItemKind { isymbol = '<' , iname = "flight of steps" , ifreq = [("staircase up", 1)] , iflavour = zipPlain [BrWhite] , icount = 1 , irarity = [(1, 1)] , iverbHit = "crash" -- the verb is only used when the item hits, -- not when it's applied otherwise, e.g., from tile , iweight = 100000 , idamage = 0 , iaspects = [] , ieffects = [Ascend True] , ifeature = [Durable] , idesc = "Stairs that rise towards escape." , ikit = [] } stairsDown = stairsUp { isymbol = '>' , iname = "flight of steps" , ifreq = [("staircase down", 1)] , ieffects = [Ascend False] , idesc = "" } escape = stairsUp { isymbol = 'E' , iname = "way" , ifreq = [("escape", 1)] , iflavour = zipPlain [BrYellow] , ieffects = [Escape] , idesc = "" } staircaseTrapUp = ItemKind { isymbol = '^' , iname = "staircase trap" , ifreq = [("staircase trap up", 1)] , iflavour = zipPlain [Red] , icount = 1 , irarity = [(1, 1)] , iverbHit = "buffet" , iweight = 10000 , idamage = 0 , iaspects = [] , ieffects = [ Temporary "be caught in an updraft" , Teleport $ 3 + 1 `dL` 10 ] , ifeature = [] -- not Durable, springs at most once , idesc = "A hidden spring, to help the unwary soar." , ikit = [] } -- Needs to be separate from staircaseTrapUp, to make sure the item is -- registered after up staircase (not only after down staircase) -- so that effects are invoked in the proper order and, e.g., teleport works. staircaseTrapDown = staircaseTrapUp { ifreq = [("staircase trap down", 1)] , iverbHit = "open up under" , ieffects = [ Temporary "tumble down the stairwell" , toOrganGood "drunk" (20 + 1 `d` 5) ] , idesc = "A treacherous slab, to teach those who are too proud." } pulpit = ItemKind { isymbol = '?' , iname = "lectern" , ifreq = [("pulpit", 1)] , iflavour = zipFancy [BrYellow] , icount = 1 , irarity = [(1, 1)] , iverbHit = "ask" , iweight = 10000 , idamage = 0 , iaspects = [] , ieffects = [ OneOf [ CreateItem CGround "any scroll" timerNone , Detect DetectAll 20 , toOrganBad "defenseless" $ (1 `dL` 6) * 10 , toOrganGood "drunk" (20 + 1 `d` 5) ] , Explode "PhD defense question" ] , ifeature = [] -- not Durable, springs at most once , idesc = "A dark wood stand, where strange priests once preached." , ikit = [] } LambdaHack-0.8.3.0/GameDefinition/Content/ModeKindPlayer.hs0000644000000000000000000001154213315545734021531 0ustar0000000000000000-- | Basic players definitions. module Content.ModeKindPlayer ( playerHero, playerAntiHero, playerCivilian , playerMonster, playerAntiMonster, playerAnimal , playerHorror, playerMonsterTourist, playerHunamConvict , playerAnimalMagnificent, playerAnimalExquisite , hiHero, hiDweller, hiRaid, hiEscapist ) where import Prelude () import Game.LambdaHack.Common.Prelude import Game.LambdaHack.Common.Ability import Game.LambdaHack.Common.Misc import Game.LambdaHack.Content.ModeKind playerHero, playerAntiHero, playerCivilian, playerMonster, playerAntiMonster, playerAnimal, playerHorror, playerMonsterTourist, playerHunamConvict, playerAnimalMagnificent, playerAnimalExquisite :: Player playerHero = Player { fname = "Explorer" , fgroups = ["hero"] , fskillsOther = meleeAdjacent , fcanEscape = True , fneverEmpty = True , fhiCondPoly = hiHero , fhasGender = True , ftactic = TExplore , fleaderMode = LeaderUI $ AutoLeader False False , fhasUI = True } playerAntiHero = playerHero { fleaderMode = LeaderAI $ AutoLeader True False , fhasUI = False } playerCivilian = Player { fname = "Civilian" , fgroups = ["hero", "civilian"] , fskillsOther = zeroSkills -- not coordinated by any leadership , fcanEscape = False , fneverEmpty = True , fhiCondPoly = hiDweller , fhasGender = True , ftactic = TPatrol , fleaderMode = LeaderNull -- unorganized , fhasUI = False } playerMonster = Player { fname = "Monster Hive" , fgroups = ["monster", "mobile monster"] , fskillsOther = zeroSkills , fcanEscape = False , fneverEmpty = False , fhiCondPoly = hiDweller , fhasGender = False , ftactic = TExplore , fleaderMode = -- No point changing leader on level, since all move and they -- don't follow the leader. LeaderAI $ AutoLeader True True , fhasUI = False } playerAntiMonster = playerMonster { fhasUI = True , fleaderMode = LeaderUI $ AutoLeader True True } playerAnimal = Player { fname = "Animal Kingdom" , fgroups = ["animal", "mobile animal", "immobile animal", "scavenger"] , fskillsOther = zeroSkills , fcanEscape = False , fneverEmpty = False , fhiCondPoly = hiDweller , fhasGender = False , ftactic = TRoam -- can't pick up, so no point exploring , fleaderMode = LeaderNull , fhasUI = False } -- | 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 brawl game between two hero factions land in the horror faction. -- In every game, either all factions for which summoning items exist -- should be present or a horror player should be added to host them. playerHorror = Player { fname = "Horror Den" , fgroups = [nameOfHorrorFact] , fskillsOther = zeroSkills , fcanEscape = False , fneverEmpty = False , fhiCondPoly = [] , fhasGender = False , ftactic = TPatrol -- disoriented , fleaderMode = LeaderNull , fhasUI = False } playerMonsterTourist = playerAntiMonster { fname = "Monster Tourist Office" , fcanEscape = True , fneverEmpty = True -- no spawning , fhiCondPoly = hiEscapist , ftactic = TFollow -- follow-the-guide, as tourists do , fleaderMode = LeaderUI $ AutoLeader False False } playerHunamConvict = playerCivilian { fname = "Hunam Convict" , fleaderMode = LeaderAI $ AutoLeader True False } playerAnimalMagnificent = playerAnimal { fname = "Animal Magnificent Specimen Variety" , fneverEmpty = True , fleaderMode = -- False to move away from stairs LeaderAI $ AutoLeader True False } playerAnimalExquisite = playerAnimal { fname = "Animal Exquisite Herds and Packs Galore" , fneverEmpty = True } victoryOutcomes :: [Outcome] victoryOutcomes = [Conquer, Escape] hiHero, hiRaid, hiDweller, hiEscapist :: HiCondPoly -- Heroes rejoice in loot. hiHero = [ ( [(HiLoot, 1000)] -- multiplied by fraction of collected , [minBound..maxBound] ) , ( [(HiConst, 1000), (HiLoss, -1)] , victoryOutcomes ) ] hiRaid = [ ( [(HiLoot, 100)] , [minBound..maxBound] ) , ( [(HiConst, 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, so big win reward , victoryOutcomes ) , ( [(HiConst, 1000), (HiLoss, -10)] , victoryOutcomes ) , ( [(HiBlitz, -100)] -- speed matters , victoryOutcomes ) , ( [(HiSurvival, 100)] , [minBound..maxBound] \\ victoryOutcomes ) ] hiEscapist = ( [(HiLoot, 200)] -- loot matters a little bit , [minBound..maxBound] ) : hiDweller LambdaHack-0.8.3.0/GameDefinition/Content/TileKind.hs0000644000000000000000000005372613315545734020377 0ustar0000000000000000-- | Terrain tile definitions. module Content.TileKind ( content ) where import Prelude () import Game.LambdaHack.Common.Prelude import qualified Data.Text as T import Game.LambdaHack.Common.Color import Game.LambdaHack.Common.Misc import Game.LambdaHack.Content.TileKind content :: [TileKind] content = [unknown, unknownOuterFence, basicOuterFence, bedrock, wall, wallSuspect, wallObscured, wallH, wallSuspectH, wallObscuredDefacedH, wallObscuredFrescoedH, pillar, pillarCache, lampPost, signboardUnread, signboardRead, tree, treeBurnt, treeBurning, rubble, rubbleSpice, doorTrapped, doorClosed, doorTrappedH, doorClosedH, stairsUp, stairsTrappedUp, stairsOutdoorUp, stairsGatedUp, stairsDown, stairsTrappedDown, stairsOutdoorDown, stairsGatedDown, escapeUp, escapeDown, escapeOutdoorDown, wallGlass, wallGlassSpice, wallGlassH, wallGlassHSpice, pillarIce, pulpit, bush, bushBurnt, bushBurning, floorFog, floorFogDark, floorSmoke, floorSmokeDark, doorOpen, doorOpenH, floorCorridor, floorArena, floorNoise, floorDirt, floorDirtSpice, floorActor, floorActorItem, floorRed, floorBlue, floorGreen, floorBrown, floorArenaShade, outdoorFence ] ++ map makeDark ldarkable ++ map makeDarkColor ldarkColorable unknown, unknownOuterFence, basicOuterFence, bedrock, wall, wallSuspect, wallObscured, wallH, wallSuspectH, wallObscuredDefacedH, wallObscuredFrescoedH, pillar, pillarCache, lampPost, signboardUnread, signboardRead, tree, treeBurnt, treeBurning, rubble, rubbleSpice, doorTrapped, doorClosed, doorTrappedH, doorClosedH, stairsUp, stairsTrappedUp, stairsOutdoorUp, stairsGatedUp, stairsDown, stairsTrappedDown, stairsOutdoorDown, stairsGatedDown, escapeUp, escapeDown, escapeOutdoorDown, wallGlass, wallGlassSpice, wallGlassH, wallGlassHSpice, pillarIce, pulpit, bush, bushBurnt, bushBurning, floorFog, floorFogDark, floorSmoke, floorSmokeDark, doorOpen, doorOpenH, floorCorridor, floorArena, floorNoise, floorDirt, floorDirtSpice, floorActor, floorActorItem, floorRed, floorBlue, floorGreen, floorBrown, floorArenaShade, outdoorFence :: TileKind ldarkable :: [TileKind] ldarkable = [wall, wallSuspect, wallObscured, wallH, wallSuspectH, wallObscuredDefacedH, wallObscuredFrescoedH, doorTrapped, doorClosed, doorTrappedH, doorClosedH, wallGlass, wallGlassH, doorOpen, doorOpenH, floorCorridor] ldarkColorable :: [TileKind] ldarkColorable = [tree, bush, floorArena, floorNoise, floorDirt, floorDirtSpice, floorActor, floorActorItem] -- Symbols to be used (the Nethack visual tradition imposes inconsistency): -- LOS noLOS -- Walk .|-# :; -- noWalk %^-| -| O&<>+ -- -- can be opened ^&+ -- can be closed |- -- some noWalk can be changed without opening, regardless of symbol -- not used yet: -- ~ (water, acid, ect.) -- : (curtain, etc., not flowing, but solid and static) -- `' (not visible enough, would need font modification) -- Note that for AI hints and UI comfort, most multiple-use @Embed@ tiles -- should have a variant, which after first use transforms into a different -- colour tile without @ChangeTo@ and similar (which then AI no longer touches). -- If a tile is supposed to be repeatedly activated by AI (e.g., cache), -- it should keep @ChangeTo@ for the whole time. -- * Main tiles, in other games modified and some removed -- ** Not walkable -- *** Not clear unknown = TileKind -- needs to have index 0 and alter 1 { tsymbol = ' ' , tname = "unknown space" , tfreq = [("unknown space", 1)] , tcolor = defFG , tcolor2 = defFG , talter = 1 , tfeature = [Dark] } unknownOuterFence = TileKind { tsymbol = ' ' , tname = "unknown space" , tfreq = [("unknown outer fence", 1)] , tcolor = defFG , tcolor2 = defFG , talter = maxBound -- impenetrable , tfeature = [Dark] } basicOuterFence = TileKind { tsymbol = ' ' , tname = "impenetrable bedrock" , tfreq = [("basic outer fence", 1), ("noise fence", 1)] , tcolor = defFG , tcolor2 = defFG , talter = maxBound -- impenetrable , tfeature = [Dark] } bedrock = TileKind { tsymbol = ' ' , tname = "bedrock" , tfreq = [("fillerWall", 1), ("legendLit", 100), ("legendDark", 100)] , tcolor = defFG , tcolor2 = defFG , talter = 100 , tfeature = [Dark] -- Bedrock being dark is bad for AI (forces it to backtrack to explore -- bedrock at corridor turns) and induces human micromanagement -- if there can be corridors joined diagonally (humans have to check -- with the xhair if the dark space is bedrock or unexplored). -- Lit bedrock would be even worse for humans, because it's harder -- to guess which tiles are unknown and which can be explored bedrock. -- The setup of Allure is ideal, with lit bedrock that is easily -- distinguished from an unknown tile. However, LH follows the NetHack, -- not the Angband, visual tradition, so we can't improve the situation, -- unless we turn to subtle shades of black or non-ASCII glyphs, -- but that is yet different aesthetics. } wall = TileKind { tsymbol = '|' , tname = "granite wall" , tfreq = [("legendLit", 100), ("rectWindowsOver_!_Lit", 80)] , tcolor = BrWhite , tcolor2 = defFG , talter = 100 , tfeature = [BuildAs "suspect vertical wall Lit"] } wallSuspect = TileKind -- only on client { tsymbol = '|' , tname = "suspect uneven wall" , tfreq = [("suspect vertical wall Lit", 1)] , tcolor = BrWhite , tcolor2 = defFG , talter = 2 , tfeature = [ RevealAs "trapped vertical door Lit" , ObscureAs "obscured vertical wall Lit" ] } wallObscured = TileKind { tsymbol = '|' , tname = "scratched wall" , tfreq = [("obscured vertical wall Lit", 1)] , tcolor = BrWhite , tcolor2 = defFG , talter = 5 , tfeature = [ Embed "scratch on wall" , HideAs "suspect vertical wall Lit" ] } wallH = TileKind { tsymbol = '-' , tname = "sandstone wall" , tfreq = [("legendLit", 100), ("rectWindowsOver_=_Lit", 80)] , tcolor = BrWhite , tcolor2 = defFG , talter = 100 , tfeature = [BuildAs "suspect horizontal wall Lit"] } wallSuspectH = TileKind -- only on client { tsymbol = '-' , tname = "suspect painted wall" , tfreq = [("suspect horizontal wall Lit", 1)] , tcolor = BrWhite , tcolor2 = defFG , talter = 2 , tfeature = [ RevealAs "trapped horizontal door Lit" , ObscureAs "obscured horizontal wall Lit" ] } wallObscuredDefacedH = TileKind { tsymbol = '-' , tname = "defaced wall" , tfreq = [("obscured horizontal wall Lit", 90)] , tcolor = BrWhite , tcolor2 = defFG , talter = 5 , tfeature = [ Embed "obscene pictogram" , HideAs "suspect horizontal wall Lit" ] } wallObscuredFrescoedH = TileKind { tsymbol = '-' , tname = "frescoed wall" , tfreq = [("obscured horizontal wall Lit", 10)] , tcolor = BrWhite , tcolor2 = defFG , talter = 5 , tfeature = [ Embed "subtle fresco" , HideAs "suspect horizontal wall Lit" ] -- a bit beneficial, but AI would loop if allowed to trigger -- so no @ConsideredByAI@ } pillar = TileKind { tsymbol = 'O' , tname = "rock" , tfreq = [ ("cachable", 70), ("stair terminal", 100) , ("legendLit", 100), ("legendDark", 100) , ("noiseSet", 70), ("battleSet", 250), ("brawlSetLit", 50) , ("shootoutSetLit", 10), ("zooSet", 10) ] , tcolor = BrCyan -- not BrWhite, to tell from heroes , tcolor2 = Cyan , talter = 100 , tfeature = [] } pillarCache = TileKind { tsymbol = 'O' , tname = "smoothed rock" , tfreq = [("cachable", 30), ("cache", 1), ("stair terminal", 1)] , tcolor = BrBlue , tcolor2 = Blue , talter = 5 , tfeature = [ Embed "treasure cache", Embed "treasure cache trap" , ChangeTo "cachable", ConsideredByAI ] -- Not explorable, but prominently placed, so hard to miss. -- Very beneficial, so AI eager to trigger, unless wary of traps. } lampPost = TileKind { tsymbol = 'O' , tname = "lamp post" , tfreq = [("lampPostOver_O", 1)] , tcolor = BrYellow , tcolor2 = Brown , talter = 100 , tfeature = [] } signboardUnread = TileKind -- client only, indicates never used by this faction { tsymbol = 'O' , tname = "signboard" , tfreq = [("signboard unread", 1)] , tcolor = BrCyan , tcolor2 = Cyan , talter = 5 , tfeature = [ ConsideredByAI -- changes after use, so safe for AI , RevealAs "signboard" -- to display as hidden ] } signboardRead = TileKind { tsymbol = 'O' , tname = "signboard" , tfreq = [("signboard", 1), ("escapeSetDark", 1)] , tcolor = BrCyan , tcolor2 = Cyan , talter = 5 , tfeature = [Embed "signboard", HideAs "signboard unread"] } tree = TileKind { tsymbol = 'O' , tname = "tree" , tfreq = [ ("brawlSetLit", 140), ("shootoutSetLit", 10) , ("escapeSetLit", 35), ("treeShadeOver_O_Lit", 1) ] , tcolor = BrGreen , tcolor2 = Green , talter = 50 , tfeature = [] } treeBurnt = tree { tname = "burnt tree" , tfreq = [("ambushSet", 3), ("zooSet", 7), ("tree with fire", 30)] , tcolor = BrBlack , tcolor2 = BrBlack , tfeature = Dark : tfeature tree } treeBurning = tree { tname = "burning tree" , tfreq = [("ambushSet", 30), ("zooSet", 70), ("tree with fire", 70)] , tcolor = BrRed , tcolor2 = Red , talter = 5 , tfeature = Embed "big fire" : ChangeTo "tree with fire" : tfeature tree -- dousing off the tree will have more sense when it periodically -- explodes, hitting and lighting up the team and so betraying it } rubble = TileKind { tsymbol = '&' , tname = "rubble pile" , tfreq = [] -- [("floorCorridorLit", 1)] -- disabled while it's all or nothing per cave and per room; -- we need a new mechanism, Spice is not enough, because -- we don't want multicolor trailLit corridors -- ("rubbleOrNot", 70) -- until we can sync change of tile and activation, it always takes 1 turn , tcolor = BrYellow , tcolor2 = Brown , talter = 4 -- boss can dig through , tfeature = [OpenTo "rubbleOrNot", Embed "rubble"] } rubbleSpice = TileKind { tsymbol = '&' , tname = "rubble pile" , tfreq = [ ("smokeClumpOver_f_Lit", 1), ("emptySet", 1), ("noiseSet", 5) , ("zooSet", 100), ("ambushSet", 20) ] , tcolor = BrYellow , tcolor2 = Brown , talter = 4 -- boss can dig through , tfeature = [Spice, OpenTo "rubbleSpiceOrNot", Embed "rubble"] -- It's not explorable, due to not being walkable nor clear and due -- to being a door (@OpenTo@), which is kind of OK, because getting -- the item is risky and, e.g., AI doesn't attempt it. -- Also, AI doesn't go out of its way to clear the way for heroes. } doorTrapped = TileKind { tsymbol = '+' , tname = "trapped door" , tfreq = [("trapped vertical door Lit", 1)] , tcolor = BrRed , tcolor2 = Red , talter = 2 , tfeature = [ Embed "doorway trap" , OpenTo "open vertical door Lit" , HideAs "suspect vertical wall Lit" ] } doorClosed = TileKind { tsymbol = '+' , tname = "closed door" , tfreq = [("closed vertical door Lit", 1)] , tcolor = Brown , tcolor2 = BrBlack , talter = 2 , tfeature = [OpenTo "open vertical door Lit"] -- never hidden } doorTrappedH = TileKind { tsymbol = '+' , tname = "trapped door" , tfreq = [("trapped horizontal door Lit", 1)] , tcolor = BrRed , tcolor2 = Red , talter = 2 , tfeature = [ Embed "doorway trap" , OpenTo "open horizontal door Lit" , HideAs "suspect horizontal wall Lit" ] } doorClosedH = TileKind { tsymbol = '+' , tname = "closed door" , tfreq = [("closed horizontal door Lit", 1)] , tcolor = Brown , tcolor2 = BrBlack , talter = 2 , tfeature = [OpenTo "open horizontal door Lit"] -- never hidden } stairsUp = TileKind { tsymbol = '<' , tname = "staircase up" , tfreq = [("staircase up", 9), ("ordinary staircase up", 1)] , tcolor = BrWhite , tcolor2 = defFG , talter = talterForStairs , tfeature = [Embed "staircase up", ConsideredByAI] } stairsTrappedUp = TileKind { tsymbol = '<' , tname = "windy staircase up" , tfreq = [("staircase up", 1)] , tcolor = BrRed , tcolor2 = Red , talter = talterForStairs , tfeature = [ Embed "staircase up", Embed "staircase trap up" , ConsideredByAI, ChangeTo "ordinary staircase up" ] -- AI uses despite the trap; exploration more important } stairsOutdoorUp = stairsUp { tname = "signpost pointing backward" , tfreq = [("staircase outdoor up", 1)] } stairsGatedUp = stairsUp { tname = "gated staircase up" , tfreq = [("gated staircase up", 1)] , talter = talterForStairs + 2 -- animals and bosses can't use } stairsDown = TileKind { tsymbol = '>' , tname = "staircase down" , tfreq = [("staircase down", 9), ("ordinary staircase down", 1)] , tcolor = BrWhite , tcolor2 = defFG , talter = talterForStairs , tfeature = [Embed "staircase down", ConsideredByAI] } stairsTrappedDown = TileKind { tsymbol = '>' , tname = "crooked staircase down" , tfreq = [("staircase down", 1)] , tcolor = BrRed , tcolor2 = Red , talter = talterForStairs , tfeature = [ Embed "staircase down", Embed "staircase trap down" , ConsideredByAI, ChangeTo "ordinary staircase down" ] } stairsOutdoorDown = stairsDown { tname = "signpost pointing forward" , tfreq = [("staircase outdoor down", 1)] } stairsGatedDown = stairsDown { tname = "gated staircase down" , tfreq = [("gated staircase down", 1)] , talter = talterForStairs + 2 -- animals and bosses can't use } escapeUp = TileKind { tsymbol = '<' , tname = "exit hatch up" , tfreq = [("legendLit", 1), ("legendDark", 1)] , tcolor = BrYellow , tcolor2 = BrYellow , talter = 0 -- anybody can escape (or guard escape) , tfeature = [Embed "escape", ConsideredByAI] } escapeDown = TileKind { tsymbol = '>' , tname = "exit trapdoor down" , tfreq = [("legendLit", 1), ("legendDark", 1)] , tcolor = BrYellow , tcolor2 = BrYellow , talter = 0 -- anybody can escape (or guard escape) , tfeature = [Embed "escape", ConsideredByAI] } escapeOutdoorDown = escapeDown { tname = "exit back to town" , tfreq = [("escape outdoor down", 1)] } -- *** Clear wallGlass = TileKind { tsymbol = '|' , tname = "polished crystal wall" , tfreq = [("glasshouseOver_!_Lit", 1)] , tcolor = BrBlue , tcolor2 = Blue , talter = 10 , tfeature = [BuildAs "suspect vertical wall Lit", Clear] } wallGlassSpice = wallGlass { tfreq = [("rectWindowsOver_!_Lit", 20)] , tfeature = Spice : tfeature wallGlass } wallGlassH = TileKind { tsymbol = '-' , tname = "polished crystal wall" , tfreq = [("glasshouseOver_=_Lit", 1)] , tcolor = BrBlue , tcolor2 = Blue , talter = 10 , tfeature = [BuildAs "suspect horizontal wall Lit", Clear] } wallGlassHSpice = wallGlassH { tfreq = [("rectWindowsOver_=_Lit", 20)] , tfeature = Spice : tfeature wallGlassH } pillarIce = TileKind { tsymbol = '^' , tname = "ice" , tfreq = [("noiseSet", 30)] , tcolor = BrBlue , tcolor2 = Blue , talter = 4 -- boss can dig through , tfeature = [Clear, Embed "frost", OpenTo "damp stone floor"] -- Is door, due to @OpenTo@, so is not explorable, but it's OK, because -- it doesn't generate items nor clues. This saves on the need to -- get each ice pillar into sight range when exploring level. } pulpit = TileKind { tsymbol = '%' , tname = "pulpit" , tfreq = [("pulpit", 1)] , tcolor = BrYellow , tcolor2 = Brown , talter = 5 , tfeature = [Clear, Embed "pulpit"] -- mixed blessing, so AI ignores, saved for player fun } bush = TileKind { tsymbol = '%' , tname = "bush" , tfreq = [ ("bush Lit", 1), ("shootoutSetLit", 30), ("escapeSetLit", 40) , ("bushClumpOver_f_Lit", 1) ] , tcolor = BrGreen , tcolor2 = Green , talter = 10 , tfeature = [Clear] } bushBurnt = bush { tname = "burnt bush" , tfreq = [ ("battleSet", 30), ("ambushSet", 4), ("zooSet", 30) , ("bush with fire", 70) ] , tcolor = BrBlack , tcolor2 = BrBlack , tfeature = Dark : tfeature bush } bushBurning = bush { tname = "burning bush" , tfreq = [("ambushSet", 40), ("zooSet", 300), ("bush with fire", 30)] , tcolor = BrRed , tcolor2 = Red , talter = 5 , tfeature = Embed "small fire" : ChangeTo "bush with fire" : tfeature bush } -- ** Walkable -- *** Not clear floorFog = TileKind { tsymbol = ';' , tname = "faint fog" , tfreq = [ ("lit fog", 1), ("emptySet", 5), ("shootoutSetLit", 20) , ("noiseSet", 10), ("fogClumpOver_f_Lit", 60) ] -- lit fog is OK for shootout, because LOS is mutual, as opposed -- to dark fog, and so camper has little advantage, especially -- on big maps, where he doesn't know on which side of fog patch to hide , tcolor = BrCyan , tcolor2 = Cyan , talter = 0 , tfeature = [Walkable, NoItem, OftenActor] } floorFogDark = floorFog { tname = "thick fog" , tfreq = [("noiseSet", 10), ("escapeSetDark", 50)] , tfeature = Dark : tfeature floorFog } floorSmoke = TileKind { tsymbol = ';' , tname = "billowing smoke" , tfreq = [ ("lit smoke", 1), ("labTrailLit", 1), ("stair terminal", 2) , ("smokeClumpOver_f_Lit", 1) ] , tcolor = Brown , tcolor2 = BrBlack , talter = 0 , tfeature = [Walkable, NoItem] -- not dark, embers } floorSmokeDark = floorSmoke { tname = "lingering smoke" , tfreq = [("ambushSet", 60), ("zooSet", 20), ("battleSet", 5)] , tfeature = Dark : tfeature floorSmoke } -- *** Clear doorOpen = TileKind { tsymbol = '-' , tname = "open door" , tfreq = [("open vertical door Lit", 1)] , tcolor = Brown , tcolor2 = BrBlack , talter = 4 , tfeature = [ Walkable, Clear, NoItem, NoActor , CloseTo "closed vertical door Lit" ] } doorOpenH = TileKind { tsymbol = '|' , tname = "open door" , tfreq = [("open horizontal door Lit", 1)] , tcolor = Brown , tcolor2 = BrBlack , talter = 4 , tfeature = [ Walkable, Clear, NoItem, NoActor , CloseTo "closed horizontal door Lit" ] } floorCorridor = TileKind { tsymbol = '#' , tname = "corridor" , tfreq = [("floorCorridorLit", 99), ("rubbleOrNot", 30)] , tcolor = BrWhite , tcolor2 = defFG , talter = 0 , tfeature = [Walkable, Clear] } floorArena = floorCorridor { tsymbol = floorSymbol , tname = "stone floor" , tfreq = [ ("floorArenaLit", 1), ("rubbleSpiceOrNot", 30) , ("arenaSetLit", 1), ("emptySet", 97), ("zooSet", 600) ] } floorNoise = floorArena { tname = "damp stone floor" , tfreq = [("noiseSet", 60), ("damp stone floor", 1)] } floorDirt = floorArena { tname = "dirt" , tfreq = [ ("battleSet", 1000), ("brawlSetLit", 1000) , ("shootoutSetLit", 1000), ("escapeSetLit", 1000) , ("ambushSet", 1000) ] } floorDirtSpice = floorDirt { tfreq = [ ("treeShadeOver_s_Lit", 1), ("fogClumpOver_f_Lit", 40) , ("smokeClumpOver_f_Lit", 1), ("bushClumpOver_f_Lit", 1) ] , tfeature = Spice : tfeature floorDirt } floorActor = floorArena { tfreq = [("floorActorLit", 1)] -- lit even in dark cave, so no items , tfeature = OftenActor : tfeature floorArena } floorActorItem = floorActor { tfreq = [("legendLit", 100)] , tfeature = OftenItem : tfeature floorActor } floorRed = floorCorridor { tsymbol = floorSymbol , tname = "brick pavement" , tfreq = [("trailLit", 30), ("alarmingTrailLit", 70)] , tcolor = BrRed , tcolor2 = Red , tfeature = [Trail, Walkable, Clear] } floorBlue = floorRed { tname = "cobblestone path" , tfreq = [("trailLit", 100)] , tcolor = BrBlue , tcolor2 = Blue } floorGreen = floorRed { tname = "mossy stone path" , tfreq = [("trailLit", 100)] , tcolor = BrGreen , tcolor2 = Green } floorBrown = floorRed { tname = "rotting mahogany deck" , tfreq = [("trailLit", 10), ("alarmingTrailLit", 30)] , tcolor = BrMagenta , tcolor2 = Magenta } floorArenaShade = floorActor { tname = "shaded ground" , tfreq = [("shaded ground", 1), ("treeShadeOver_s_Lit", 2)] , tcolor2 = BrBlack , tfeature = Dark : NoItem : tfeature floorActor } outdoorFence = TileKind { tsymbol = ' ' , tname = "event horizon" , tfreq = [("outdoor outer fence", 1)] , tcolor = defFG , tcolor2 = defFG , talter = maxBound -- impenetrable , tfeature = [Dark] } 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 (BuildAs t) = Just $ BuildAs $ darkText t darkFeat (RevealAs t) = Just $ RevealAs $ darkText t darkFeat (ObscureAs t) = Just $ ObscureAs $ 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.8.3.0/GameDefinition/Content/ItemKindOrgan.hs0000644000000000000000000003423413315545734021360 0ustar0000000000000000-- | Actor organ definitions. module Content.ItemKindOrgan ( organs ) where import Prelude () import Game.LambdaHack.Common.Prelude import Game.LambdaHack.Common.Ability import Game.LambdaHack.Common.Color import Game.LambdaHack.Common.Dice import Game.LambdaHack.Common.Flavour import Game.LambdaHack.Common.ItemAspect (Aspect (..)) import Game.LambdaHack.Common.Misc import Game.LambdaHack.Content.ItemKind organs :: [ItemKind] organs = [fist, foot, hookedClaw, smallClaw, snout, smallJaw, jaw, largeJaw, antler, horn, rhinoHorn, tentacle, thorn, boilingFissure, arsenicFissure, sulfurFissure, beeSting, sting, venomTooth, venomFang, screechingBeak, largeTail, armoredSkin, eye2, eye3, eye4, eye5, eye6, eye7, eye8, vision4, vision5, vision6, vision7, vision8, vision10, vision12, vision14, vision16, nostril, insectMortality, sapientBrain, animalBrain, speedGland2, speedGland4, speedGland6, speedGland8, speedGland10, scentGland, boilingVent, arsenicVent, sulfurVent, bonusHP, impressed] -- LH-specific ++ [tooth, lash, noseTip, lip, torsionRight, torsionLeft, pupil] fist, foot, hookedClaw, smallClaw, snout, smallJaw, jaw, largeJaw, antler, horn, rhinoHorn, tentacle, thorn, boilingFissure, arsenicFissure, sulfurFissure, beeSting, sting, venomTooth, venomFang, screechingBeak, largeTail, armoredSkin, eye2, eye3, eye4, eye5, eye6, eye7, eye8, vision4, vision5, vision6, vision7, vision8, vision10, vision12, vision14, vision16, nostril, insectMortality, sapientBrain, animalBrain, speedGland2, speedGland4, speedGland6, speedGland8, speedGland10, scentGland, boilingVent, arsenicVent, sulfurVent, bonusHP, impressed :: ItemKind -- LH-specific tooth, lash, noseTip, lip, torsionRight, torsionLeft, pupil :: 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 , idamage = 4 `d` 1 , iaspects = [] , ieffects = [] , ifeature = [Durable, Meleeable] , idesc = "Simple but effective." , ikit = [] } foot = fist { iname = "foot" , ifreq = [("foot", 50)] , iverbHit = "kick" , idamage = 4 `d` 1 , idesc = "A weapon you can still use if disarmed." } -- * Other weapon organs hookedClaw = fist { iname = "hooked claw" , ifreq = [("hooked claw", 50)] , icount = 2 -- even if more, only the fore claws used for fighting , iverbHit = "hook" , idamage = 2 `d` 1 , iaspects = [Timeout $ 12 - 1 `dL` 3] , ieffects = [Recharging (toOrganBad "slowed" 2)] , idesc = "A curved talon." } smallClaw = fist { iname = "small claw" , ifreq = [("small claw", 50)] , iverbHit = "slash" , idamage = 2 `d` 1 , idesc = "A pearly spike." } snout = fist { iname = "snout" , ifreq = [("snout", 10)] , icount = 1 , iverbHit = "bite" , idamage = 2 `d` 1 , idesc = "Sensitive and wide-nostrilled." } smallJaw = fist { iname = "small jaw" , ifreq = [("small jaw", 20)] , icount = 1 , iverbHit = "rip" , idamage = 3 `d` 1 , idesc = "Filled with small, even teeth." } jaw = fist { iname = "jaw" , ifreq = [("jaw", 20)] , icount = 1 , iverbHit = "rip" , idamage = 5 `d` 1 , idesc = "Delivers a powerful bite." } largeJaw = fist { iname = "large jaw" , ifreq = [("large jaw", 100)] , icount = 1 , iverbHit = "crush" , idamage = 10 `d` 1 , idesc = "Enough to swallow anything in a single gulp." } antler = fist { iname = "antler" , ifreq = [("antler", 100)] , icount = 2 , iverbHit = "ram" , idamage = 4 `d` 1 , iaspects = [Timeout $ 3 + (1 `d` 3) * 3, AddArmorMelee 10] -- bonus doubled , ieffects = [Recharging (PushActor (ThrowMod 100 50))] -- 1 step, slow , idesc = "" } horn = fist { iname = "horn" , ifreq = [("horn", 100)] , icount = 2 , iverbHit = "impale" , idamage = 5 `d` 1 , iaspects = [AddHurtMelee 10, AddArmorMelee 10] -- bonus doubled , idesc = "Sharp and long, for defence or attack." } rhinoHorn = fist { iname = "ugly horn" -- made of keratin, unlike real horns , ifreq = [("rhino horn", 20)] , icount = 1 -- single, unlike real horns , iverbHit = "impale" , idamage = 5 `d` 1 , iaspects = [Timeout 7, AddHurtMelee 20] , ieffects = [Recharging Impress] -- the owner is a mid-boss, after all , idesc = "Very solid, considering it has the same composition as fingernails." } tentacle = fist { iname = "tentacle" , ifreq = [("tentacle", 50)] , icount = 4 , iverbHit = "slap" , idamage = 4 `d` 1 , idesc = "Damp and dextrous." } thorn = fist { iname = "thorn" , ifreq = [("thorn", 100)] , icount = 2 + 1 `d` 3 , iverbHit = "impale" , idamage = 2 `d` 1 , ifeature = [Meleeable] -- not Durable , idesc = "Sharp yet brittle." } boilingFissure = fist { iname = "fissure" , ifreq = [("boiling fissure", 100)] , icount = 5 + 1 `d` 5 , iverbHit = "hiss at" , idamage = 1 `d` 1 , iaspects = [AddHurtMelee 20] -- decreasing as count decreases , ieffects = [DropItem 1 1 COrgan "condition"] -- useful; limited , ifeature = [Meleeable] -- not Durable , idesc = "A deep crack to the underworld." } arsenicFissure = boilingFissure { iname = "fissure" , ifreq = [("arsenic fissure", 100)] , icount = 3 + 1 `d` 3 , idamage = 2 `d` 1 , ieffects = [] -- nothing interesting fits the weaken/poison biological data , idesc = "" } sulfurFissure = boilingFissure { iname = "fissure" , ifreq = [("sulfur fissure", 100)] , icount = 2 + 1 `d` 2 , idamage = 0 -- heal not via (negative) idamage, for armour would block it , ieffects = [RefillHP 5] , idesc = "" } beeSting = fist { iname = "bee sting" , ifreq = [("bee sting", 100)] , icount = 1 , iverbHit = "sting" , idamage = 0 , iaspects = [AddArmorMelee 200, AddArmorRanged 45] , ieffects = [Paralyze 6, RefillHP 4] , ifeature = [Meleeable] -- not Durable , idesc = "Painful, but beneficial." } sting = fist { iname = "sting" , ifreq = [("sting", 100)] , icount = 1 , iverbHit = "sting" , idamage = 1 `d` 1 , iaspects = [Timeout $ 10 - 1 `dL` 4, AddHurtMelee 40] , ieffects = [Recharging (Paralyze 4)] , idesc = "Painful, debilitating and harmful." } venomTooth = fist { iname = "venom tooth" , ifreq = [("venom tooth", 100)] , icount = 2 , iverbHit = "bite" , idamage = 2 `d` 1 , iaspects = [Timeout $ 7 - 1 `dL` 3] , ieffects = [Recharging (toOrganBad "slowed" (3 + 1 `d` 3))] , idesc = "A chilling numbness spreads from its bite." } venomFang = fist { iname = "venom fang" , ifreq = [("venom fang", 100)] , icount = 2 , iverbHit = "bite" , idamage = 2 `d` 1 , iaspects = [Timeout $ 10 - 1 `dL` 4] , ieffects = [Recharging (toOrganNoTimer "poisoned")] , idesc = "Dripping with deadly venom." } screechingBeak = fist { iname = "screeching beak" , ifreq = [("screeching beak", 100)] , icount = 1 , iverbHit = "peck" , idamage = 2 `d` 1 , iaspects = [Timeout $ 7 - 1 `dL` 3] , ieffects = [Recharging $ Summon "scavenger" $ 1 `dL` 3] , idesc = "Both a weapon and a beacon, calling more scavengers to the meal." } largeTail = fist { iname = "large tail" , ifreq = [("large tail", 50)] , icount = 1 , iverbHit = "knock" , idamage = 7 `d` 1 , iaspects = [Timeout $ 1 + 1 `d` 3, AddHurtMelee 20] , ieffects = [Recharging (PushActor (ThrowMod 400 50))] -- 2 steps , idesc = "Slow but heavy." } -- 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 , idamage = 0 , iaspects = [AddArmorMelee 30, AddArmorRanged 15] , ieffects = [] , ifeature = [Durable] , idesc = "Homemade armour is just as good." , 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 = "A piercing stare." } 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)] , iverbHit = "visualize" , iaspects = [AddSight (intToDice n)] , idesc = "" } vision4 = vision 4 vision5 = vision 5 vision6 = vision 6 vision7 = vision 7 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 = armoredSkin { iname = "insect mortality" , ifreq = [("insect mortality", 100)] , iverbHit = "age" , iaspects = [Timeout $ 30 + (1 `d` 2) * 10] , ieffects = [Recharging (RefillHP (-1))] , ifeature = [Periodic] ++ ifeature armoredSkin , idesc = "" } sapientBrain = armoredSkin { iname = "sapient brain" , ifreq = [("sapient brain", 100)] , iverbHit = "outbrain" , iaspects = [AddAbility ab 1 | ab <- [minBound..maxBound]] ++ [AddAbility AbAlter 2] -- can use stairs , idesc = "" } animalBrain = armoredSkin { iname = "animal brain" , ifreq = [("animal brain", 100)] , iverbHit = "blank" , iaspects = [AddAbility ab 1 | ab <- [minBound..maxBound]] ++ [AddAbility AbAlter 2] -- can use stairs ++ [ AddAbility ab (-1) | ab <- [AbDisplace, AbMoveItem, AbProject, AbApply] ] , idesc = "" } speedGland :: Int -> ItemKind speedGland n = armoredSkin { iname = "speed gland" , ifreq = [(toGroupName $ "speed gland" <+> tshow n, 100)] , iverbHit = "spit at" , iaspects = [ AddSpeed $ intToDice n , Timeout $ intToDice $ 100 `div` n ] , ieffects = [Recharging (RefillHP 1)] , ifeature = [Periodic] ++ ifeature armoredSkin , idesc = "" } speedGland2 = speedGland 2 speedGland4 = speedGland 4 speedGland6 = speedGland 6 speedGland8 = speedGland 8 speedGland10 = speedGland 10 scentGland = armoredSkin { iname = "scent gland" , ifreq = [("scent gland", 100)] , icount = 2 + 1 `d` 3 -- runs out , iverbHit = "spray at" , iaspects = [Timeout $ (1 `d` 3) * 10] , ieffects = [ Recharging (Temporary "look spent") , Recharging (Explode "distressing odor") , Recharging ApplyPerfume ] , ifeature = [Periodic] -- not Durable , idesc = "" } boilingVent = armoredSkin { iname = "vent" , ifreq = [("boiling vent", 100)] , iflavour = zipPlain [Blue] , iverbHit = "menace" , iaspects = [Timeout $ (2 + 1 `d` 2) * 5] , ieffects = [ Recharging (Explode "boiling water") , Recharging (RefillHP 2) ] , ifeature = [Periodic] ++ ifeature armoredSkin , idesc = "" } arsenicVent = armoredSkin { iname = "vent" , ifreq = [("arsenic vent", 100)] , iflavour = zipPlain [Cyan] , iverbHit = "menace" , iaspects = [Timeout $ (2 + 1 `d` 2) * 5] , ieffects = [ Recharging (Explode "sparse shower") , Recharging (RefillHP 2) ] , ifeature = [Periodic] ++ ifeature armoredSkin , idesc = "" } sulfurVent = armoredSkin { iname = "vent" , ifreq = [("sulfur vent", 100)] , iflavour = zipPlain [BrYellow] , iverbHit = "menace" , iaspects = [Timeout $ (2 + 1 `d` 2) * 5] , ieffects = [ Recharging (Explode "dense shower") , Recharging (RefillHP 2) ] , ifeature = [Periodic] ++ ifeature armoredSkin , idesc = "" } -- * Special bonusHP = armoredSkin { isymbol = 'H' -- '+' reserved for conditions , iname = "bonus HP" , iflavour = zipPlain [BrBlue] , ifreq = [("bonus HP", 1)] , iverbHit = "intimidate" , iweight = 0 , iaspects = [AddMaxHP 1] , idesc = "" } impressed = armoredSkin { isymbol = '!' , iname = "impressed" , iflavour = zipPlain [BrRed] , ifreq = [("impressed", 1), ("condition", 1)] , iverbHit = "confuse" , iweight = 0 , iaspects = [AddMaxCalm (-1)] -- to help player notice on main screen -- and to count as bad condition , ieffects = [OnSmash $ tmpNoLonger "impressed"] -- not @Periodic@ , ifeature = [Fragile, Durable] -- hack: destroy on drop , idesc = "" } -- * LH-specific tooth = fist { iname = "tooth" , ifreq = [("tooth", 20)] , icount = 3 , iverbHit = "nail" , idamage = 2 `d` 1 , idesc = "" } lash = fist { iname = "lash" , ifreq = [("lash", 100)] , icount = 1 , iverbHit = "lash" , idamage = 3 `d` 1 , idesc = "" } noseTip = fist { iname = "tip" , ifreq = [("nose tip", 50)] , icount = 1 , iverbHit = "poke" , idamage = 2 `d` 1 , idesc = "" } lip = fist { iname = "lip" , ifreq = [("lip", 10)] , icount = 1 , iverbHit = "lap" , idamage = 1 `d` 1 , iaspects = [Timeout $ 3 + 1 `d` 2] , ieffects = [Recharging (toOrganBad "weakened" (2 + 1 `dL` 3))] , idesc = "" } torsionRight = fist { iname = "right torsion" , ifreq = [("right torsion", 100)] , icount = 1 , iverbHit = "twist" , idamage = 13 `d` 1 , iaspects = [Timeout $ 5 + 1 `d` 5, AddHurtMelee 20] , ieffects = [Recharging (toOrganBad "slowed" (3 + 1 `d` 3))] , idesc = "" } torsionLeft = fist { iname = "left torsion" , ifreq = [("left torsion", 100)] , icount = 1 , iverbHit = "twist" , idamage = 13 `d` 1 , iaspects = [Timeout $ 5 + 1 `d` 5, AddHurtMelee 20] , ieffects = [Recharging (toOrganBad "weakened" (3 + 1 `d` 3))] , idesc = "" } pupil = fist { iname = "pupil" , ifreq = [("pupil", 100)] , icount = 1 , iverbHit = "gaze at" , idamage = 1 `d` 1 , iaspects = [AddSight 12, Timeout 12] , ieffects = [ Recharging (DropItem 1 maxBound COrgan "condition") , Recharging $ RefillCalm (-10) ] , idesc = "" } LambdaHack-0.8.3.0/GameDefinition/Client/0000755000000000000000000000000013315545733016126 5ustar0000000000000000LambdaHack-0.8.3.0/GameDefinition/Client/UI/0000755000000000000000000000000013315545733016443 5ustar0000000000000000LambdaHack-0.8.3.0/GameDefinition/Client/UI/Content/0000755000000000000000000000000013315545734020056 5ustar0000000000000000LambdaHack-0.8.3.0/GameDefinition/Client/UI/Content/KeyKind.hs0000644000000000000000000002652713315545734021764 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 Prelude () import Game.LambdaHack.Common.Prelude import Game.LambdaHack.Client.UI.Content.KeyKind import Game.LambdaHack.Client.UI.HandleHelperM (ppSLore) import Game.LambdaHack.Client.UI.HumanCmd import Game.LambdaHack.Common.Misc import qualified Game.LambdaHack.Content.TileKind as TK -- | Description of default key-command bindings. -- -- In addition to these commands, mouse and keys have a standard meaning -- when navigating various menus. standardKeys :: KeyKind standardKeys = KeyKind $ map evalKeyDef $ -- All commands are defined here, except some movement and leader picking -- commands. All commands are shown on help screens except debug commands -- and macros with empty descriptions. -- The order below determines the order on the help screens. -- Remember to put commands that show information (e.g., enter aiming -- mode) first. -- Main menu [ ("e", ([CmdMainMenu], "enter challenges menu>", ChallengesMenu)) , ("s", ([CmdMainMenu], "start new game", GameRestart)) , ("x", ([CmdMainMenu], "exit to desktop", GameExit)) , ("v", ([CmdMainMenu], "visit settings menu>", SettingsMenu)) , ("a", ([CmdMainMenu], "automate faction", Automate)) , ("?", ([CmdMainMenu], "see command help", Help)) , ("F12", ([CmdMainMenu], "go to dashboard", Dashboard)) , ("Escape", ([CmdMainMenu], "back to playing", Cancel)) -- Minimal command set, in the desired presentation order , ("g", addCmdCategory CmdMinimal $ grabItems "grab item(s)") -- actually it's not necessary, ground items menu suffices , ("Escape", ( [CmdMinimal, CmdAim] , "cancel aiming/open main menu" , ByAimMode { exploration = ExecuteIfClear MainMenu , aiming = Cancel } )) , ("Return", ( [CmdMinimal, CmdAim] , "accept target/open dashboard" , ByAimMode { exploration = ExecuteIfClear Dashboard , aiming = Accept } )) , ("space", ( [CmdMinimal, CmdMeta] , "clear messages/display history" , ExecuteIfClear History )) -- not necessary, because messages available from dashboard , ("BackTab", ( [CmdMinimal, CmdMove] , "cycle among all party members" , MemberBack )) , ("KP_Multiply", ( [CmdMinimal, CmdAim] , "cycle x-hair among enemies" , AimEnemy )) -- not necessary, because flinging from item menu enters aiming mode , ("C-c", ([CmdMinimal, CmdMove], "open or close or alter", AlterDir [])) , ("+", ([CmdMinimal, CmdAim], "swerve the aiming line", EpsIncr True)) -- Item menu, first part of item use commands , ("comma", grabItems "") , ("d", dropItems "drop item(s)") , ("period", dropItems "") , ("f", addCmdCategory CmdItemMenu $ projectA flingTs) , ("C-f", addCmdCategory CmdItemMenu $ replaceDesc "fling without aiming" $ projectI flingTs) , ("a", addCmdCategory CmdItemMenu $ applyI [TriggerItem { tiverb = "apply" , tiobject = "consumable" , tisymbols = "!?/" }]) , ("C-a", addCmdCategory CmdItemMenu $ replaceDesc "apply and keep choice" $ applyIK [TriggerItem { tiverb = "apply" , tiobject = "consumable" , tisymbols = "!?/" }]) , ("p", moveItemTriple [CGround, CEqp, CSha] CInv "item" False) , ("e", moveItemTriple [CGround, CInv, CSha] CEqp "item" False) , ("s", moveItemTriple [CGround, CInv, CEqp] CSha "and share item" False) -- Terrain exploration and alteration , ("Tab", ( [CmdMove] , "cycle among party members on the level" , MemberCycle )) , ("c", ([CmdMove], descTs closeDoorTriggers, AlterDir closeDoorTriggers)) , ("=", ( [CmdMove], "select (or deselect) party member", SelectActor) ) , ("_", ([CmdMove], "deselect (or select) all on the level", SelectNone)) , ("semicolon", ( [CmdMove] , "go to x-hair for 25 steps" , Macro ["C-semicolon", "C-/", "C-V"] )) , ("colon", ( [CmdMove] , "run to x-hair collectively for 25 steps" , Macro ["C-colon", "C-/", "C-V"] )) , ("x", ( [CmdMove] , "explore nearest unknown spot" , autoexploreCmd )) , ("X", ( [CmdMove] , "autoexplore 25 times" , autoexplore25Cmd )) , ("R", ([CmdMove], "rest (wait 25 times)", Macro ["KP_5", "C-V"])) , ("C-R", ( [CmdMove], "lurk (wait 0.1 turns 100 times)" , Macro ["C-KP_5", "V"] )) -- Item use, continued , ("^", ( [CmdItem], "sort items by ownership, kind and stats", SortSlots)) , ("P", ( [CmdItem, CmdDashboard] , "manage item pack of the leader" , ChooseItemMenu (MStore CInv) )) , ("G", ( [CmdItem, CmdDashboard] , "manage items on the ground" , ChooseItemMenu (MStore CGround) )) , ("E", ( [CmdItem, CmdDashboard] , "manage equipment of the leader" , ChooseItemMenu (MStore CEqp) )) , ("S", ( [CmdItem, CmdDashboard] , "manage the shared party stash" , ChooseItemMenu (MStore CSha) )) , ("A", ( [CmdItem, CmdDashboard] , "manage all owned items" , ChooseItemMenu MOwned )) , ("@", ( [CmdItem, CmdDashboard] , "describe organs of the leader" , ChooseItemMenu MOrgans )) , ("#", ( [CmdItem, CmdDashboard] , "show stat summary of the leader" , ChooseItemMenu MStats )) , ("~", ( [CmdItem] , "display known lore" , ChooseItemMenu (MLore SItem) )) , ("q", addCmdCategory CmdItem $ applyI [TriggerItem { tiverb = "quaff" , tiobject = "potion" , tisymbols = "!" }]) , ("r", addCmdCategory CmdItem $ applyI [TriggerItem { tiverb = "read" , tiobject = "scroll" , tisymbols = "?" }]) , ("t", addCmdCategory CmdItem $ projectA [ TriggerItem { tiverb = "throw" , tiobject = "missile" , tisymbols = "|" } ]) -- , ("z", projectA [TriggerItem { tiverb = "zap" -- , tiobject = "instrument" -- , tisymbol = "/" }]) -- Dashboard, in addition to commands marked above , ("safeD0", ([CmdInternal, CmdDashboard], "", Cancel)) -- blank line ] ++ map (\(k, slore) -> ("safeD" ++ show (k :: Int) , ( [CmdInternal, CmdDashboard] , "display" <+> ppSLore slore <+> "lore" , ChooseItemMenu (MLore slore) ))) (zip [1..] [minBound..maxBound]) ++ [ ("safeD99", ([CmdInternal, CmdDashboard], "", Cancel)) -- blank line -- Aiming , ("!", ([CmdAim], "", AimEnemy)) , ("KP_Divide", ([CmdAim], "cycle x-hair among items", AimItem)) , ("/", ([CmdAim], "", AimItem)) , ("-", ([CmdAim], "unswerve the aiming line", EpsIncr False)) , ("\\", ([CmdAim], "cycle aiming modes", AimFloor)) , ("C-?", ( [CmdAim] , "set x-hair to nearest unknown spot" , XhairUnknown )) , ("C-I", ( [CmdAim] , "set x-hair to nearest item" , XhairItem )) , ("C-{", ( [CmdAim] , "set x-hair to nearest upstairs" , XhairStair True )) , ("C-}", ( [CmdAim] , "set x-hair to nearest dnstairs" , XhairStair False )) , ("<", ([CmdAim], "move aiming one level up" , AimAscend 1)) , ("C-<", ( [CmdNoHelp], "move aiming 10 levels up" , AimAscend 10) ) , (">", ([CmdAim], "move aiming one level down", AimAscend (-1))) -- 'lower' would be misleading in some games, just as 'deeper' , ("C->", ( [CmdNoHelp], "move aiming 10 levels down" , AimAscend (-10)) ) , ("BackSpace" , ( [CmdAim] , "clear chosen item and target" , ComposeUnlessError ItemClear TgtClear )) -- Assorted , ("F12", ([CmdMeta], "open dashboard", Dashboard)) , ("?", ([CmdMeta], "display help", Hint)) , ("F1", ([CmdMeta], "", Hint)) , ("v", ([CmdMeta], "voice again the recorded commands", Repeat 1)) , ("V", repeatTriple 100) , ("C-v", repeatTriple 1000) , ("C-V", repeatTriple 25) , ("'", ([CmdMeta], "start recording commands", Record)) , ("C-P", ([CmdMeta], "print screen", PrintScreen)) -- Dashboard, in addition to commands marked above , ("safeD100", ([CmdInternal, CmdDashboard], "display help", Help)) , ("safeD101", ([CmdInternal, CmdDashboard], "display history", History)) -- Mouse , ("LeftButtonRelease", mouseLMB) , ("RightButtonRelease", mouseRMB) , ("C-LeftButtonRelease", replaceDesc "" mouseRMB) -- Mac convention , ( "C-RightButtonRelease" , ([CmdMouse], "open or close or alter at pointer", AlterWithPointer []) ) , ("MiddleButtonRelease", mouseMMB) , ("WheelNorth", ([CmdMouse], "swerve the aiming line", Macro ["+"])) , ("WheelSouth", ([CmdMouse], "unswerve the aiming line", Macro ["-"])) -- Debug and others not to display in help screens , ("C-S", ([CmdDebug], "save game", GameSave)) , ("C-semicolon", ( [CmdNoHelp] , "move one step towards the x-hair" , MoveOnceToXhair )) , ("C-colon", ( [CmdNoHelp] , "run collectively one step towards the x-hair" , RunOnceToXhair )) , ("C-/", ( [CmdNoHelp] , "continue towards the x-hair" , ContinueToXhair )) , ("C-comma", ([CmdNoHelp], "run once ahead", RunOnceAhead)) , ("safe1", ( [CmdInternal] , "go to pointer for 25 steps" , goToCmd )) , ("safe2", ( [CmdInternal] , "run to pointer collectively" , runToAllCmd )) , ("safe3", ( [CmdInternal] , "pick new leader on screen" , PickLeaderWithPointer )) , ("safe4", ( [CmdInternal] , "select party member on screen" , SelectWithPointer )) , ("safe5", ( [CmdInternal] , "set x-hair to enemy" , AimPointerEnemy )) , ("safe6", ( [CmdInternal] , "fling at enemy under pointer" , aimFlingCmd )) , ("safe7", ( [CmdInternal, CmdDashboard] , "open main menu" , MainMenu )) , ("safe8", ( [CmdInternal] , "cancel aiming" , Cancel )) , ("safe9", ( [CmdInternal] , "accept target" , Accept )) , ("safe10", ( [CmdInternal] , "wait a turn, bracing for impact" , Wait )) , ("safe11", ( [CmdInternal] , "wait 0.1 of a turn" , Wait10 )) ] ++ map defaultHeroSelect [0..6] closeDoorTriggers :: [TriggerTile] closeDoorTriggers = [ TriggerTile { ttverb = "close" , ttobject = "door" , ttfeature = TK.CloseTo "closed vertical door Lit" } , TriggerTile { ttverb = "close" , ttobject = "door" , ttfeature = TK.CloseTo "closed horizontal door Lit" } , TriggerTile { ttverb = "close" , ttobject = "door" , ttfeature = TK.CloseTo "closed vertical door Dark" } , TriggerTile { ttverb = "close" , ttobject = "door" , ttfeature = TK.CloseTo "closed horizontal door Dark" } ] LambdaHack-0.8.3.0/GameDefinition/Implementation/0000755000000000000000000000000013315545734017676 5ustar0000000000000000LambdaHack-0.8.3.0/GameDefinition/Implementation/MonadClientImplementation.hs0000644000000000000000000001330313315545734025335 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | The implementation of our custom game client monads. Just as any other -- component of the library, this implementation can be substituted. module Implementation.MonadClientImplementation ( executorCli #ifdef EXPOSE_INTERNAL -- * Internal operations , CliState(..), CliImplementation(..) #endif ) where import Prelude () import Game.LambdaHack.Common.Prelude import Control.Concurrent import qualified Control.Monad.IO.Class as IO import Control.Monad.Trans.State.Strict hiding (State) import Game.LambdaHack.Atomic (MonadStateWrite (..), putState) import Game.LambdaHack.Client import Game.LambdaHack.Client.HandleAtomicM import Game.LambdaHack.Client.HandleResponseM import Game.LambdaHack.Client.LoopM import Game.LambdaHack.Client.MonadClient import Game.LambdaHack.Client.State import Game.LambdaHack.Client.UI import Game.LambdaHack.Client.UI.SessionUI import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.Kind import Game.LambdaHack.Common.MonadStateRead import qualified Game.LambdaHack.Common.Save as Save import Game.LambdaHack.Common.State import Game.LambdaHack.Server (ChanServer (..)) data CliState = CliState { cliState :: State -- ^ current global state , cliClient :: StateClient -- ^ current client state , cliSession :: Maybe SessionUI -- ^ UI state, empty for AI clients , cliDict :: ChanServer -- ^ this client connection information , cliToSave :: Save.ChanSave (StateClient, Maybe SessionUI) -- ^ connection to the save thread } -- | Client state transformation monad. newtype CliImplementation a = CliImplementation { runCliImplementation :: StateT CliState IO a } deriving (Monad, Functor, Applicative) instance MonadStateRead CliImplementation where {-# INLINE getsState #-} getsState f = CliImplementation $ gets $ f . cliState instance MonadStateWrite CliImplementation where {-# INLINE modifyState #-} modifyState f = CliImplementation $ state $ \cliS -> let !newCliState = f $ cliState cliS in ((), cliS {cliState = newCliState}) instance MonadClient CliImplementation where {-# INLINE getsClient #-} getsClient f = CliImplementation $ gets $ f . cliClient {-# INLINE modifyClient #-} modifyClient f = CliImplementation $ state $ \cliS -> let !newCliState = f $ cliClient cliS in ((), cliS {cliClient = newCliState}) liftIO = CliImplementation . IO.liftIO instance MonadClientSetup CliImplementation where saveClient = CliImplementation $ do toSave <- gets cliToSave cli <- gets cliClient msess <- gets cliSession IO.liftIO $ Save.saveToChan toSave (cli, msess) restartClient = CliImplementation $ state $ \cliS -> case cliSession cliS of Just sess -> let !newSess = (emptySessionUI (sUIOptions sess)) { schanF = schanF sess , sbinding = sbinding sess , shistory = shistory sess , sstart = sstart sess , sgstart = sgstart sess , sallTime = sallTime sess , snframes = snframes sess , sallNframes = sallNframes sess } in ((), cliS {cliSession = Just newSess}) Nothing -> ((), cliS) instance MonadClientUI CliImplementation where {-# INLINE getsSession #-} getsSession f = CliImplementation $ gets $ f . fromJust . cliSession {-# INLINE modifySession #-} modifySession f = CliImplementation $ state $ \cliS -> let !newCliSession = f $ fromJust $ cliSession cliS in ((), cliS {cliSession = Just newCliSession}) liftIO = CliImplementation . IO.liftIO instance MonadClientReadResponse CliImplementation where receiveResponse = CliImplementation $ do ChanServer{responseS} <- gets cliDict IO.liftIO $ takeMVar responseS instance MonadClientWriteRequest CliImplementation where sendRequestAI scmd = CliImplementation $ do ChanServer{requestAIS} <- gets cliDict IO.liftIO $ putMVar requestAIS scmd sendRequestUI scmd = CliImplementation $ do ChanServer{requestUIS} <- gets cliDict IO.liftIO $ putMVar (fromJust requestUIS) scmd clientHasUI = CliImplementation $ do mSession <- gets cliSession return $! isJust mSession instance MonadClientAtomic CliImplementation where {-# INLINE execUpdAtomic #-} execUpdAtomic _ = return () -- handleUpdAtomic, until needed, save resources -- Don't catch anything; assume exceptions impossible. {-# INLINE execPutState #-} execPutState = putState -- | Run the main client loop, with the given arguments and empty -- initial states, in the @IO@ monad. executorCli :: KeyKind -> UIOptions -> ClientOptions -> COps -> Bool -> FactionId -> ChanServer -> IO () executorCli copsClient sUIOptions clientOptions cops isUI fid cliDict = let cliSession | isUI = Just $ emptySessionUI sUIOptions | otherwise = Nothing stateToFileName (cli, _) = ssavePrefixCli (soptions cli) <> Save.saveNameCli cops (sside cli) totalState cliToSave = CliState { cliState = updateCOpsAndCachedData (const cops) emptyState -- state is empty, so the cached data is left empty and untouched , cliClient = emptyStateClient fid , cliDict , cliToSave , cliSession } m = loopCli copsClient sUIOptions clientOptions exe = evalStateT (runCliImplementation m) . totalState in Save.wrapInSaves cops stateToFileName exe LambdaHack-0.8.3.0/GameDefinition/Implementation/MonadServerImplementation.hs0000644000000000000000000002130213315545734025363 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | The implementation of our custom game server monads. Just as any other -- component of the library, this implementation can be substituted. module Implementation.MonadServerImplementation ( executorSer #ifdef EXPOSE_INTERNAL -- * Internal operations , SerState(..), SerImplementation(..) #endif ) where import Prelude () import Game.LambdaHack.Common.Prelude 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 qualified Data.Text.IO as T import Options.Applicative (defaultPrefs, execParserPure, handleParseResult) import System.Exit (ExitCode (ExitSuccess)) import System.FilePath import System.IO (hFlush, stdout) import Game.LambdaHack.Atomic import Game.LambdaHack.Client import Game.LambdaHack.Common.File import Game.LambdaHack.Common.Kind import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.MonadStateRead import qualified Game.LambdaHack.Common.Save as Save import Game.LambdaHack.Common.State import Game.LambdaHack.Common.Thread import Game.LambdaHack.Server import Game.LambdaHack.Server.BroadcastAtomic import Game.LambdaHack.Server.HandleAtomicM import Game.LambdaHack.Server.MonadServer import Game.LambdaHack.Server.ProtocolM import Game.LambdaHack.Server.ServerOptions import Game.LambdaHack.Server.State import Implementation.MonadClientImplementation (executorCli) data SerState = SerState { serState :: State -- ^ current global state , serServer :: StateServer -- ^ current server state , serDict :: ConnServerDict -- ^ client-server connection information , serToSave :: Save.ChanSave (State, StateServer) -- ^ connection to the save thread } -- | Server state transformation monad. newtype SerImplementation a = SerImplementation {runSerImplementation :: StateT SerState IO a} deriving (Monad, Functor, Applicative) instance MonadStateRead SerImplementation where {-# INLINE getsState #-} getsState f = SerImplementation $ gets $ f . serState instance MonadStateWrite SerImplementation where {-# INLINE modifyState #-} modifyState f = SerImplementation $ state $ \serS -> let !newSerState = f $ serState serS in ((), serS {serState = newSerState}) instance MonadServer SerImplementation where {-# INLINE getsServer #-} getsServer f = SerImplementation $ gets $ f . serServer {-# INLINE modifyServer #-} modifyServer f = SerImplementation $ state $ \serS -> let !newSerServer = f $ serServer serS in ((), serS {serServer = newSerServer}) chanSaveServer = SerImplementation $ gets serToSave liftIO = SerImplementation . IO.liftIO instance MonadServerComm SerImplementation where {-# INLINE getsDict #-} getsDict f = SerImplementation $ gets $ f . serDict {-# INLINE modifyDict #-} modifyDict f = SerImplementation $ state $ \serS -> let !newSerDict = f $ serDict serS in ((), serS {serDict = newSerDict}) liftIO = SerImplementation . IO.liftIO instance MonadServerAtomic SerImplementation where execUpdAtomic cmd = do oldState <- getState (ps, atomicBroken, executedOnServer) <- handleCmdAtomicServer cmd when executedOnServer $ cmdAtomicSemSer oldState cmd handleAndBroadcast ps atomicBroken (UpdAtomic cmd) execUpdAtomicSer cmd = SerImplementation $ StateT $ \cliS -> do cliSNewOrE <- Ex.try $ execStateT (runSerImplementation $ handleUpdAtomic cmd) cliS case cliSNewOrE of Left AtomicFail{} -> return (False, cliS) Right cliSNew -> -- We know @cliSNew@ differs only in @serState@. return (True, cliSNew) execUpdAtomicFid fid cmd = SerImplementation $ StateT $ \cliS -> do -- Don't catch anything; assume exceptions impossible. let sFid = sclientStates (serServer cliS) EM.! fid cliSNew <- execStateT (runSerImplementation $ handleUpdAtomic cmd) cliS {serState = sFid} -- We know @cliSNew@ differs only in @serState@. let serServerNew = (serServer cliS) {sclientStates = EM.insert fid (serState cliSNew) $ sclientStates $ serServer cliS} return $! ((), cliS {serServer = serServerNew}) execUpdAtomicFidCatch fid cmd = SerImplementation $ StateT $ \cliS -> do let sFid = sclientStates (serServer cliS) EM.! fid cliSNewOrE <- Ex.try $ execStateT (runSerImplementation $ handleUpdAtomic cmd) cliS {serState = sFid} case cliSNewOrE of Left AtomicFail{} -> return (False, cliS) Right cliSNew -> do -- We know @cliSNew@ differs only in @serState@. let serServerNew = (serServer cliS) {sclientStates = EM.insert fid (serState cliSNew) $ sclientStates $ serServer cliS} return $! (True, cliS {serServer = serServerNew}) execSfxAtomic sfx = do ps <- posSfxAtomic sfx handleAndBroadcast ps [] (SfxAtomic sfx) execSendPer = sendPer -- Don't inline this, to keep GHC hard work inside the library -- for easy access of code analysis tools. -- | Run the main server loop, with the given arguments and empty -- initial states, in the @IO@ monad. executorSer :: COps -> KeyKind -> ServerOptions -> IO () executorSer cops copsClient soptionsNxtCmdline = do -- Parse UI client configuration file. -- It is reparsed at each start of the game executable. let benchmark = sbenchmark $ sclientOptions soptionsNxtCmdline -- Fail here, not inside client code, so that savefiles are not removed, -- because they are not the source of the failure. sUIOptions <- mkUIOptions cops benchmark soptionsNxt <- case uCmdline sUIOptions of [] -> return soptionsNxtCmdline args -> handleParseResult $ execParserPure defaultPrefs serverOptionsPI args -- Options for the clients modified with the configuration file. -- The client debug inside server debug only holds the client commandline -- options and is never updated with config options, etc. let clientOptions = applyUIOptions cops sUIOptions $ sclientOptions soptionsNxt -- Partially applied main loop of the clients. executorClient = executorCli copsClient sUIOptions clientOptions cops -- Wire together game content, the main loop of game clients -- and the game server loop. let stateToFileName (_, ser) = ssavePrefixSer (soptions ser) <> Save.saveNameSer cops totalState serToSave = SerState { serState = updateCOpsAndCachedData (const cops) emptyState -- state is empty, so the cached data is left empty and untouched , serServer = emptyStateServer , serDict = EM.empty , serToSave } m = loopSer soptionsNxt executorClient exe = evalStateT (runSerImplementation m) . totalState exeWithSaves = Save.wrapInSaves cops stateToFileName exe defPrefix = ssavePrefixSer defServerOptions bkpOneSave name = do dataDir <- appDataDir let path bkp = dataDir "saves" bkp <> name b <- doesFileExist (path "") when b $ renameFile (path "") (path "bkp.") bkpAllSaves = if benchmark then return () else do T.hPutStrLn stdout "The game crashed, so savefiles are moved aside." bkpOneSave $ defPrefix <> Save.saveNameSer cops forM_ [-99..99] $ \n -> bkpOneSave $ defPrefix <> Save.saveNameCli cops (toEnum n) -- Wait for clients to exit even in case of server crash -- (or server and client crash), which gives them time to save -- and report their own inconsistencies, if any. Ex.handle (\ex -> case Ex.fromException ex of Just ExitSuccess -> -- User-forced shutdown, not crash, so the intention is -- to keep old saves and also clients may be not ready to save. Ex.throwIO ex _ -> do Ex.uninterruptibleMask_ $ threadDelay 1000000 -- let clients report their errors and save when (ssavePrefixSer soptionsNxt == defPrefix) bkpAllSaves hFlush stdout Ex.throwIO ex -- crash eventually, which kills clients ) exeWithSaves -- T.hPutStrLn stdout "Server exiting, waiting for clients." -- hFlush stdout waitForChildren childrenServer -- no crash, wait for clients indefinitely -- T.hPutStrLn stdout "Server exiting now." -- hFlush stdout LambdaHack-0.8.3.0/GameDefinition/Implementation/TieKnot.hs0000644000000000000000000000660513315545734021616 0ustar0000000000000000-- | Here the knot of engine code pieces, frontend and the game-specific -- content definitions is tied, resulting in an executable game. module Implementation.TieKnot ( tieKnot ) where import Prelude () import Game.LambdaHack.Common.Prelude import qualified System.Random as R import Game.LambdaHack.Common.Kind import qualified Game.LambdaHack.Common.Tile as Tile import qualified Game.LambdaHack.Content.CaveKind as CK import qualified Game.LambdaHack.Content.ItemKind as IK import qualified Game.LambdaHack.Content.ModeKind as MK import qualified Game.LambdaHack.Content.PlaceKind as PK import qualified Game.LambdaHack.Content.RuleKind as RK import qualified Game.LambdaHack.Content.TileKind as TK import Game.LambdaHack.Server import qualified Client.UI.Content.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 Implementation.MonadServerImplementation (executorSer) -- | Tie the LambdaHack engine client, server and frontend code -- with the game-specific content definitions, and run the game. -- -- The custom monad types to be used are determined by the 'executorSer' -- call, which in turn calls 'executorCli'. If other functions are used -- in their place- the types are different and so the whole pattern -- of computation differs. Which of the frontends is run inside the UI client -- depends on the flags supplied when compiling the engine library. -- Similarly for the choice of native vs JS builds. tieKnot :: ServerOptions -> IO () tieKnot options@ServerOptions{sallClear, sboostRandomItem, sdungeonRng} = do -- This setup ensures the boosting option doesn't affect generating initial -- RNG for dungeon, etc., and also, that setting dungeon RNG on commandline -- equal to what was generated last time, ensures the same item boost. initialGen <- maybe R.getStdGen return sdungeonRng let soptionsNxt = options {sdungeonRng = Just initialGen} boostedItems = IK.boostItemKindList initialGen Content.ItemKind.items coitem = IK.makeData $ if sboostRandomItem then boostedItems ++ Content.ItemKind.otherItemContent else Content.ItemKind.content coItemSpeedup = IK.speedupItem coitem cotile = TK.makeData coitem Content.TileKind.content coTileSpeedup = Tile.speedupTile sallClear cotile coplace = PK.makeData cotile Content.PlaceKind.content cocave = CK.makeData coitem coplace cotile Content.CaveKind.content -- Common content operations, created from content definitions. -- Evaluated fully to discover errors ASAP and to free memory. -- Fail here, not inside server code, so that savefiles are not removed, -- because they are not the source of the failure. !cops = COps { cocave , coitem , comode = MK.makeData cocave coitem Content.ModeKind.content , coplace , corule = RK.makeData Content.RuleKind.content , cotile , coItemSpeedup , coTileSpeedup } -- Client content operations containing default keypresses -- and command descriptions. !copsClient = Content.KeyKind.standardKeys -- Wire together game content, the main loops of game clients -- and the game server loop. executorSer cops copsClient soptionsNxt LambdaHack-0.8.3.0/GameDefinition/fonts/0000755000000000000000000000000013315545734016042 5ustar0000000000000000LambdaHack-0.8.3.0/GameDefinition/fonts/LICENSE.16x16x0000644000000000000000000004325413315545734020033 0ustar0000000000000000 GNU GENERAL PUBLIC LICENSE Version 2, June 1991 Copyright (C) 1989, 1991 Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This General Public License applies to most of the Free Software Foundation's software and to any other program whose authors commit to using it. (Some other Free Software Foundation software is covered by the GNU Lesser General Public License instead.) You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that redistributors of a free program will individually obtain patent licenses, in effect making the program proprietary. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any derivative work under copyright law: that is to say, a work containing the Program or a portion of it, either verbatim or with modifications and/or translated into another language. (Hereinafter, translation is included without limitation in the term "modification".) Each licensee is addressed as "you". Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running the Program is not restricted, and the output from the Program is covered only if its contents constitute a work based on the Program (independent of having been made by running the Program). Whether that is true depends on what the Program does. 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and give any other recipients of the Program a copy of this License along with the Program. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Program or any portion of it, thus forming a work based on the Program, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) You must cause the modified files to carry prominent notices stating that you changed the files and the date of any change. b) You must cause any work that you distribute or publish, that in whole or in part contains or is derived from the Program or any part thereof, to be licensed as a whole at no charge to all third parties under the terms of this License. c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the most ordinary way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this License. (Exception: if the Program itself is interactive but does not normally print such an announcement, your work based on the Program is not required to print an announcement.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Program, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Program, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Program. In addition, mere aggregation of another work not based on the Program with the Program (or with a work based on the Program) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may copy and distribute the Program (or a work based on it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you also do one of the following: a) Accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, b) Accompany it with a written offer, valid for at least three years, to give any third party, for a charge no more than your cost of physically performing source distribution, a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, c) Accompany it with the information you received as to the offer to distribute corresponding source code. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form with such an offer, in accord with Subsection b above.) The source code for a work means the preferred form of the work for making modifications to it. For an executable work, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the executable. However, as a special exception, the source code distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. If distribution of executable or object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place counts as distribution of the source code, even though third parties are not compelled to copy the source along with the object code. 4. You may not copy, modify, sublicense, or distribute the Program except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense or distribute the Program is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 5. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Program or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Program (or any work based on the Program), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Program or works based on it. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties to this License. 7. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Program at all. For example, if a patent license would not permit royalty-free redistribution of the Program by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Program. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system, which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 8. If the distribution and/or use of the Program is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Program under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 9. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of this License, you may choose any version ever published by the Free Software Foundation. 10. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to the public, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) year name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (which makes passes at compilers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice This General Public License does not permit incorporating your program into proprietary programs. If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the GNU Lesser General Public License instead of this License. LambdaHack-0.8.3.0/GameDefinition/fonts/16x16x.fon0000644000000000000000000002316013315545734017525 0ustar0000000000000000MZ @ !L!This Program cannot be run in DOS mode $NE+@@zP2K0PFONTDIR16x16x'FONTRES 100,96,96 : 16x16x 12 (VGA res)P$Leon Marrick, 2005. Freeware. Share and enjoy! ``X0 $~16x16x$Leon Marrick, 2005. Freeware. Share and enjoy! ``X0 $~~>^~>^~>^~>^~ > ^ ~      > ^ ~      > ^ ~      > ^ ~      > ^ ~     >^~>^~>^~>^~>^~>^~>^~>^~>^~>^~>^~>^~>^~>^~>^~>^~>^~>^~ > ^ ~     !>!^!~!!!!!">"^"~"""""#>#^#~#####$>$^$  kz{oUUUUUUUUUUUU"%"HDH @( H@A@  @@@@5jUVU?UU* VVX`ujժժժժVUUUUU`@@ըz   .pppx&2L :UjUjU.TTT谀F]:o@@@(dTT %@ ` @% H H ```` ?? ?? 0000000𘀀6"6 0`8lDl8800=p܌```````  `` 00`80000008p88p ? 80??p00p?  ?8888??```````??00?? ?88807?800888?? 8p800800888008 ?88800????0000p'.,,,,' ddddp 00``00 ??000??000??p0p88800008??00000000??p88p??000??000????000??00000800008x00000??0000080`p80088<<663311 <FNV^fnv~&.6>FNV^fnv~&.6>FNV^fnv~&.6>FNV^fnv~    & . 6 > F N V ^ f n v ~                     & . 6 > F N V ^ f n v ~                     & . 6 > F N V ^ f n v ~                     & . 6 > F N V ^ f n v ߖUUU$H@ @@<<8|||8 v|T(~ի~Zl(8(P 8lTl*"\zf(@@<<$$$lllll|||f6j8l8vv0 000  l88l000000 <00 0`f<0000 0`0 ~~0  0F>``|fff|>```>>fff>ff><``lvfff8<  L8``flxlf8<lvfffff>\2000>p<|00x000fffn6l8x0xfff><~ 0~ 0 0 02LUUUU8d`d8200x@$Z<X||~`x`~~`x`~~`x`~$~`x`~<<<<<<$<<FF(<``|f|``$ff><8X8xbLambdaHack-0.8.3.0/GameDefinition/fonts/LICENSE.Fix15Mono-Bold0000644000000000000000000001064313315545734021455 0ustar0000000000000000Digitized data copyright (c) 2012-2015, The Mozilla Foundation and Telefonica S.A. with Reserved Font Name < Fira >, This Font Software is licensed under the SIL Open Font License, Version 1.1. This license is copied below, and is also available with a FAQ at: http://scripts.sil.org/OFL ----------------------------------------------------------- SIL OPEN FONT LICENSE Version 1.1 - 26 February 2007 ----------------------------------------------------------- PREAMBLE The goals of the Open Font License (OFL) are to stimulate worldwide development of collaborative font projects, to support the font creation efforts of academic and linguistic communities, and to provide a free and open framework in which fonts may be shared and improved in partnership with others. The OFL allows the licensed fonts to be used, studied, modified and redistributed freely as long as they are not sold by themselves. The fonts, including any derivative works, can be bundled, embedded, redistributed and/or sold with any software provided that any reserved names are not used by derivative works. The fonts and derivatives, however, cannot be released under any other type of license. The requirement for fonts to remain under this license does not apply to any document created using the fonts or their derivatives. DEFINITIONS "Font Software" refers to the set of files released by the Copyright Holder(s) under this license and clearly marked as such. This may include source files, build scripts and documentation. "Reserved Font Name" refers to any names specified as such after the copyright statement(s). "Original Version" refers to the collection of Font Software components as distributed by the Copyright Holder(s). "Modified Version" refers to any derivative made by adding to, deleting, or substituting -- in part or in whole -- any of the components of the Original Version, by changing formats or by porting the Font Software to a new environment. "Author" refers to any designer, engineer, programmer, technical writer or other person who contributed to the Font Software. PERMISSION & CONDITIONS Permission is hereby granted, free of charge, to any person obtaining a copy of the Font Software, to use, study, copy, merge, embed, modify, redistribute, and sell modified and unmodified copies of the Font Software, subject to the following conditions: 1) Neither the Font Software nor any of its individual components, in Original or Modified Versions, may be sold by itself. 2) Original or Modified Versions of the Font Software may be bundled, redistributed and/or sold with any software, provided that each copy contains the above copyright notice and this license. These can be included either as stand-alone text files, human-readable headers or in the appropriate machine-readable metadata fields within text or binary files as long as those fields can be easily viewed by the user. 3) No Modified Version of the Font Software may use the Reserved Font Name(s) unless explicit written permission is granted by the corresponding Copyright Holder. This restriction only applies to the primary font name as presented to the users. 4) The name(s) of the Copyright Holder(s) or the Author(s) of the Font Software shall not be used to promote, endorse or advertise any Modified Version, except to acknowledge the contribution(s) of the Copyright Holder(s) and the Author(s) or with their explicit written permission. 5) The Font Software, modified or unmodified, in part or in whole, must be distributed entirely under this license, and must not be distributed under any other license. The requirement for fonts to remain under this license does not apply to any document created using the Font Software. TERMINATION This license becomes null and void if any of the above conditions are not met. DISCLAIMER THE FONT SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO ANY WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT OF COPYRIGHT, PATENT, TRADEMARK, OR OTHER RIGHT. IN NO EVENT SHALL THE COPYRIGHT HOLDER BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, INCLUDING ANY GENERAL, SPECIAL, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL DAMAGES, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF THE USE OR INABILITY TO USE THE FONT SOFTWARE OR FROM OTHER DEALINGS IN THE FONT SOFTWARE. LambdaHack-0.8.3.0/GameDefinition/fonts/Fix15Mono-Bold.woff0000644000000000000000000027475413315545734021353 0ustar0000000000000000wOFFyPFFTMsGDEFwDqGPOSh};YfGSUBLL@FOS/24X`bcmap .\Ncvt $> /fpgm$ gasp*glyf*BLKheadBH66 x hheaB!$thmtxB :!TlocaN0@5!maxp\ name\^post`Q5nXprepyXm=a.xKQSulczm#{b`i/7ɯ`Қ=ꚆѴ">ZjrnMozWoyCy SNA8 n-w'«|MWC~Fãc9I,UuԜzo?j*w5k#kt.x[PUy?s=s^(,K KYABH"",a)c)1 ,uYj(Za0:qXb85Ƹu1b 8,`;Ç&̎s.?~wsZ@/ J+kf̓h@> 6&կחW/RM_MezJ뛀[oX񸬃<@R@qt i~\.6d*.vF~F1W-ϬgBHc`O|%|_M|Q S|J(JS \٤lV-JU٦Pv*=J_9R(ǔ)r^W.+W)eF* !!$ MH>)"TROI i#I'Ev d'd%c" d WTZj&+L5G]jZVjڤjڥv{}jzPT'zN^RMzWOE)>Gi MY4Mt3[h3Jt't?=@#=IO3<U:Eg-:K jD3-^KR -["TЪ^kZ6m֩vk{>m@; iǵamT;i mRnh9mee ,`,aJVjYkbu.}d(;Fiv]`v]g7vELqzYzN/Kr}YӷV}CߩA!_n{Jk~ 9|ctD~\ɆÅOߟWmd?h%d;>Χõ~ҢmO\>cDD/أ.sfUa@#?upB <ؽυge6BxP?st j~SpkT~ُ}0>=jQg99aqkb~'7-~K[x|(.x#`kzCh^>,?VijڭnMvk[:en>۾9hA.ÑxT\/.WFM:Ti}ħN}BC~R?e>Y`@cIFadyFQdFQcFfl7:]ncg !1lg11aL 1g̛D&5-3L0fc1 b̬4Zl2[v2=>ҹgR8-| Uā ٸ{硽;yAȫ.vsi8%gwW8cyűAc.1ocvr󘋇91y8\sK ]̂8]\ᵜMn8wǚ)w9~ޥ܍rq:w.- v\o:ĭ\;x~9+Cۜltc= /Yݼr9<<8J.n]9.o*g-;np-D o ?}UhP5v;; +|( q¿ yzyy  )gVXZ5@4&0, BX&-n^x x*3%"R/%IR-IRT*UHURT/5J-R]vIR4 Ұ4*Ƥ҄4)MK7Ҝ4B" ŢVL֠TP%F5VԎ:PF{>ԏAt@#4:.K ˢe&89QN,9W^'%rI,[fyM!{^y|@>$'S<._S|K b qN8|\Kq57܆N {q>(>E<'4o9<)TX%AIVV(JF)P2RVjIiUڕKV(~2UN(#irA\Q)וrF|$$NH.YG I )'fRGfl#;NCz~r"G1r"gy2N.d̐[d# *Tj1jjEjZV5jڨmvSݥV}zXRzVS/:Pos<QJ-Kh2]A3i]C h1-D[i;]h?=HQz@/+No;.֘D-EKײ\mVh&mVmњ6mSzvD;NigڸvYMi3-mV-03X gI,elY+eհzZX:.e}lfC8f,cdؼtSc=Y_g9@/JZ&Uo;.[ߣ~T?s~E_ow}C4 g$)FeB(76Aj_ȗ .~ĵa9KUŦ?_ xYg\䫛a_-U~i:B }cc گ\%0r+ܽS[V hdUae`5aoRዶ:B=e\-W23:<1ñ Ua~q/?q,oßR g;x}͓ތBξsYLy;͇[/{|5Z̞;g0Y._Í(d>eFgWK_"~d t ;`ԁs|B}|O(JMCD]̀SV@N0`өM>T_vp%q+n2Mz~g χ/kػxW{P?w=,)oDѩؙI1 " MJM65&ڇtlhv2it2ijfLD;阞{Ca%nJf2wܳw;@@Q`[W V/d'Γ _!hi qChv 'l.q%%N8̊r'\w9Uha v;UA ۨ%nп1~P@ {@!-BZph""ih*#VyZj`n65͞*xN|Eio|K_D'}D^56&ZSsWAK[e niܢ"ZVܤ9NjdH=AdHho "2TdH-.=0Ev%^^ ip/Bz^h Axq8 Yx prXE}:ukǚ y5W[sFO)ʻ{k9NkZQkК/<Ǟe>_fǚ{}sw? {2zHh:xHXg^ sG ,4@'m4oVz{'h^ctCS5R;rӏ!*TDTr2ZNTB++-4P=WV}_ a5F;a}~ưoF07Ly~O۴NOߧsz~DG 8bqq0(>/A<cx_—$i| x?;^/ƏckvCW\}|]]XUL5F+ajFRmGZYٸ߬ZhnNs)]|gx@;Qb}F?a:A:I;x|':JYOVƯUBGRMeOS f=MGpt:DkXw(ֲ9:ZzUz:Fhs:F}-2u,>:WA^o wpw\}>I:*8B]b9!Kŕ9Qz ~?^{3TL+s}T\ӓ7 ːzx0VvC@ܹ?nmttdɄ\]2O\CUș Z)M˯R}|T_a[ hf9`*f Hd^6ci2yWL1`0P0#Z'=SζξQ7<3+w11.w>9 bQY,<㝅w`5XA%#LDs(#t+x o'x9\oyN"x[SSluVW~brCn;w ݰ;-v5Pt`4-Bou>[u>OwY}A_[M{^[/j.)CA:fp 0qmgDa< =iĴA ޴+vuLwEuMt0`g3qzҖ}'H[ܓv]ݛ։z=iн>*ӖK[Ǵv'L􍴟~+ݒ.I{`Q0 (ЩԝԍTWZ*:lJ$'sɬLd(i%~ʿo7W%?~[WB+i)Dnvf|_>^/Ov---͏͊U*bi)ؠ7:w\8qTWȪ6?~gjC8d.x 2~%uo/.i*2~&u'mk66Xs̭_L"Q3Oo,>#CWQ=RD:LZiVuF~=u y)jI`m&S8OQ>{,,|OxFLŌ*QERYyjš JF*S%zXFE5R[3gPGKu^oQ%>:?7Ia_ j?EL2nSBz΋3Ÿ1ìv_A~2}sC>k$P 3'O ${1ȅb\D6H΄@pR9 h({3O}f׊$=cf4&RYwHo$<!9gE1ln5 6Ol]s&5;k5gfyr=K|Lr~5f1ǙЏN7^ 6w`?De~mΦw=(j6Sbf+fZuV6wf7?cYg;HG`u v5B9l>͌ ~;og}֏;>\ F C1 BHBKA.,1@ bx|L$H~x*9r̖}*{,2=ք].%}*Zk!6ZVX֜1xc` a C V&aJ}g:=oL0q8}G5Y2xVisV$NBuyij?B0`B,.JPZ)v}~͕ig7~Z}M I;Ôa|ϻ:zw JgVvt٢0:2Q0:o6! "!S(M{Us; ہM%ʨ"IIqV5f>oNbA FIF#+ "vpe=b ^;tiLp?$3r($$ ~_F~%zODw'k" o ts'#Xv(h+L1+bƔ?$/94;9u}7f2%k' ?>ex[GɞP/'2,Gɘ 3eXMzI٢멉S^eeX/B;OMflUԍ(3]~@!Mii5s:%.xEf4Tk7HrzLCoVI ֟U1Gfl&gg?d.b;H8yldK6V_A&D$M߄RR0%呱7MSj^wi M9)o`9Ә1\%gl]@|١E,gTeJr,RIyT2mX (Q!C% :TC*˯{]-#K>YJr>,G+*|dVsEC}"O㣸*29h82J^c@+96*DKI\!ã9WgǍ`N4zcO7d5d."ˈ/;:tEUZ/*UX*h"wzlbuELi..~[f B^WBzڋǢA9 }s+xYa=ͬdχ.lyR{(]/鼸/#A%,f@ %,4N0"mÀ#y4Tح#*j'N [(u΁&2ȁ!57 !ƸZ52`Qc7@)ؗaNJ89M uR*#os[Q|⥮k sBPQ % Iz]K;5Zu&B>a ߖ Dȋp9eǧ` t-Κ>e<}c|`2\Mihs|m0a]0cm/K0 dp9 3Wa9 0 f 0246wp{E7F?j4bϊj#/|_5bo1##>h1X=eyե'Ł8]Y!\fb_j~ ;6C25߰Mz~ ӧIOWdLf wwEIޖlÏ.1o^BwyyV[8XYk,^P)v{ !Ѧ_9g2ta*CG% ƚXgFPk#1utM1cҠR+eCCDNKS&g!HA KrhIE[U%ԇ>eW}$>ˊS$J)b: 7(:.:o6StBkP3{|زM }zE2Hyi켔dDе 4.#i3MCdiaΗKhC)nmp)5 ˿p)&:;333'3';+#=- slR̦Btz|*=`?A#@9K €u\Կ! -^ut4{#߾|;{,e0~RDÕE/i5@H"eD0k`l0 .MufIgS SYBl߀$ 3mg 6KN޷riٝi+jt몞9N_Ϫ@{5~qO)%}¿"%]ڻ)G޴ skRsNЌ.=^{!H|+Ĩ@(յχ^=#cT@q,+vA7LtZFMO 2A;˝K2~wnJFJÆ;./d/j$aGCP.-k~׷oy[Ŗn1g}}kg}>B~um@?zkkuB+b?; vS ;t[ PɠoKIϘ1Xݰt|ra"IM2P@G4 4PaϜħ N&$?.Ar=f/,7b_e'ai*ʡݾxuFsi]bґ߰`E VoT{/\~h]cEtiQ`1yKQbApÞ4/p* Sk$g)M.yo..;9$ѲB(E ?xӶo?kqmhdҁ uGߘPZw_wC?tL6'L:D"69C=x~oz6Ґ4P [7^K\ߡ‡2-;e;2-8@$ l>I -m^0+=aM^φ- ji0C D`e/EЃ/x%7k0s&?DFujA-'toP)IdCzّ[Vڴ֊7dB04#{'R 겻ֱ=S7ӽxw Gx7EhP.#tY  45oij*oY4}4bx&IvHTɽP1!$rMTOtL3rid0;*BPm {:3(1;;=551TO;;3љ谤@q0@qC"rڅGkO7tvL??ů>o<ՋvxMy5~>0l/Wds9Y H+V6P6[NS j%%](_T<(_ʠlo$y߿>rWx_g`]p2<9)+R q(a-U@ɕ8iViIt2N$ NFU D_$'4H>QUqz$e  fɿq?\5\U&ݸ*[RDح07PM%`LJݝ oW8J6 $pVNalX4 *IJ &욣 D9%x.hJ58d@@HPWhhG3Yvg~8YlҢ@q}(N$N0 qk7M ˮ\NZ~tґf 6\V=\|s?`9;DW#W-i,%.CQdX|XN/MNOuH!`5dQ pQiA * j$fwMeMK#_lW:dRI]S;pfc' - Br݋9nu>~_>r:lI}ovPzN8t5Nv/gdSc`~qPsKfN 0Ew"uHA ǽ_Y/aBeEE_;Ń] j z\,IjskˮE/ܾ5WF>V!3qĉ ӿ|V& TTpr̳f3uU.:‘sXξ Ü? szH9+JfH)ɶGpa[)VSAN<_PX@풨ZTUpʺN@JvXj#;ۖjy=Kݒ| 4Z{ZkKle9ȏ s,ˊ++ξ s`v( rC`FSY$YMJvP,'+ OD :2+~ =+nzKk]gu5'9;r6dfU_ؾsAy+.vM]`~.7RO&7(VDƴU|j)lA ԙ/ʒNtEo˅ ,(|+., K^?^^at9L9b\"Ʌ*=ZD@d%!#ت(G7-bp."a4Ӭ.TD Y`y-koMZJXPPߐ_y0z'er$\Y t5*}Ld~-2 ;ON@nggܶ(V$NwŒ vvMVP٫g@1 [-t~IAzy+Y$i!Bͨ3Eٰ2: Ric1@@稗$ݠڧ5;<:YajII4zp)B  w+ Ue慼 ~_C].,ɯ93pqfddwm_>_0Y|REm~c:5 3@;W88 D0,$ V&ОQxX` j+TT/}^/'UnziFbI"ƒna2w/3,+;Fl`^fnf1_qȒ[P5ddcXڐ_qhӵ:JvՑmM-uy9<~ x`.uͩq* Qށ0QjA6 S" pY : |D)/5†0=VSJ[UOtUΝ'OsS'`{FP3$s Yd ",]D;X(~ \.%,H-v懭|ѡ|a|BomMovuwW._;2u&%,=/>(ீa?\8I(҂IJ ̅எ5m"N(5r1LР\Ie[(5LR“NC7*ru-o}Ϟ`^=gs?sJ2Jŗڿ'j"IuyRBjs>2~;swzH#Hco~=J ,m(!5;j( t*gV-I;R3{xZik䅇XfJ>zj܀f–8xVVM>a~]g]sl G[:kpǗ :j@њb*Rb jFg"f?y>9sOع_iTI>r&7|uU︸f{Yoc5ޚZjkm#]Z?~ ȪqȽLB^c%MҰ-N']!zS"Q%A+`x#?G+z({NIkib+cdR[XK'WPHYo9CLQNP Y&`'7bfJqvɉtրZ-$-I#I"ϧ8؀z?wnGC(ޑޑU=O땯~>s~A=(WN{dG(F:BcҘ 'c&ZY.mn8nn\ p)6Ug'{}i`mΝޫES+)cͷ^% ]Su˶ ϛ5c. :go_y,|'xhkhgL',|_Ċ̓G'W m# ^4؏&S#'rcQD^$يtVI,rs~_^+z{{"?qعMW|e ◹x{8 3H)I2e+FS ,46É5(F#ºdro[/mX|d^w`a[OGZƑCYY#;ݒ~%$E.GUV#A~V,,Ƹ_gcь_kS~B Fh-23fImEء)ķnxk%4A 66_ b_!{Cmu_ EXԝ߽&J@C.>gQ(X H8xQ>Abe]"wVp»?ޕH=odH!]Ic6Hl2eQP$ʪM}[ɽ5&ʓü>"ޒ_z/{m|Ē[R'[`M"no6$>OĒ/_ жt^~λrw|KoV,Fz_~aB Me>E䞰 ΥzzUSdrsaLCsTms4}no*a^}sW(a͢*ٖ,lq^w-74Ӕig 4nһr=UW[{m_z&'c;c3ǣ#=2d˴6-TDJuR{J2#m1L)Mp JNGq6Q`F[! H1`w06f}btB_AJGy{ Kzs}a;4z!EAZtUukF7dn9=*mY)c#Gn|dU{O7<=xF,PhyE"qI9KrCB;U\؛o:s[W9|gG:}}G]y55O-fU҉Ѥ8eOL/*:Ҍee$1~  P, qa$yUd3>W=y)6 [LK&*֬vmamG(-eO׺｡H[9E.,h0º:`.n 1 ZbNZ;6:$@S003n8Lg"]n<0 Fu7޴H[ozu7+Z^}]«\?][τ&2E,$VaH +^1 ls!٥@ZeMŠL/l'64X=&߅4(ģw.*im˿}~bbM#F h{a{gFXi7&RCɏ h{ 5E&g$qDgt &(3ѱxg&F#Cab0ԢFuU7ȨvrVn,t.)wFk6?4" 4P2vE0~03=3[z0nAwJrҼD~hkqhkU֊շE"m@yN-ںmjveba"Ո_=rVϖuo@8F=Cp!`UYWږ =};J;`^A[?^ZvpK~&cY"#VJ.FeRP.?g) CZ=F@"ͳP$qF{$t'`aQzl`fK$#R3Yy ."OSȧ:_޼uIH]Uk7 BP^!_'f9[♰*#gE&Aa4=e538T,F,;և\z‘a-g@ԐQ;bp USfGAމ΂^DC|@z(3,XTff\CJ8愷 <}H4ၙ_<d5u++rm>PRp1kC^(׊rNv䳀 d9%Ʌ*N~JfEZ?{ ^^84V8A 9.޾=2<:-/-X6xxMZaOw4-YfOڒSP w7p_8nfÐ(ߩ3 dHZАEmlj⹃@Q] AuHdyٸcwS_UXTa4mǶ!N]/"5JD8x9(H!by\ĸ9t*"7bڬa%72[ȍ|]YOsohXzQ_NN3A?^vD~lvtaXiͲm7_2kd=V3x1xO"8pV=z2-d%ib Ѫp`a@c<"hepil;g˽twt[N9 Qٖ΢tY@4JMx)Ji؆CK 3LAk ThO~K<_#]`~GV(uԟ,o Ppg1kK6%lS[ l3 XLU}ҽ=}mƉJ^$k+ֿcgog?<3y hߎbR p!qt@O.[q;r 5ېC77[258v H 啥TKuɴ%9(9Xo]!]}-qE &.OxmJG}.5Wо{Rl+ir=H;,)mkO2Epy<`gc F95;N#!2. ##䦉 MCwpy. t$]Y&6kf89{-Ni"I k´GjQQog~f^};+O?}#ɜL͗XڛeѥM 7h2$Z44ۙZjѪ?KXŊ 70#U~oe_5_;]Β,f0iHQH wNHq#(1S^7ӣAΚޮ@uVkm[Nf4,I D =#my\1P":Ve?P'HL/-rYBNc[-  f*{-ؼ!ҕް)֝tgg[[{{feu.lZT+3|q/VVVU">Mf_c爓5?tGi?Ӏ2]NzndE;ݞ'؍H=YS\HUH:'s3QݖY.e4;3)Ȯ UT$;!E9PúBou=+vtvj?\.gf#%!=zmaHMImi ;KK "i_==c$]Rk5B " {0F Elf[j^Vx.+kJݮTEaell30l} PØ~MQPd~0Ril1Y٘Ņy~K|$pEL 6Yت1CH~u4<0y#N?@swßZZtQ֕G+gpVܵgws"gZ}BBeGp7r{3Q'Ű-#m^o4ȧ8Q d mF#*3|~V; 0F\`0FTW.!E~on+(E\lȢ٧jܲS'0=+zҦ 'd8}']jYr*jp58F$:>\zЯЧgd,m\ܕNKLXIfN0ͱ *xB1tyt.C*+*hPIͯrӓO?e;5os%dCd;Ag3fv!eX*;4<8G#YҦS;|yt -b9/՛1 Hy |g@4LLzU Ďmp姷0k簄ssqJrr ~_JNJvﶤvjpW]r`9˱Knv䶡m55ۆ`Fv$ƱW=gp }Lpl6`<5^wKr;)R(߭_o NS0P9f { > I޵ 񟜏d$<">pDʝD#h5L?+Nd_αJ Kc>/ٜpd,Gf>Zp$A0=dGo/:w-|^|s!۲%m^ѯum/UKӞWGu˞B:1<ƈSX_)J-T-?IS8z!o0yc'U t%ܽfG p4p% $`޼yy6,)?)eVp#(.| S)l/͡:}-Ʊ%'YPo~%w͋cȔ_ oPDtI4xB6X`:"-eO6<P8|>&__^_PVPZ\id|n% Cѥ3svA0PQ`y3QoZ*}iM8 4ȧJ)kײ(&Ɣ*+vT 2r+HbpKN1tx m&B[u͛-C+)2%UǿRR}}^#[3n3t}N߹Iz}}xpV۽{hz#ȿ"NdqY!p+֜q{5'8)㈀"s'NW߱u.C*aL;J8_}֦9S}QP8Q9@hѻy.فtHqUaUs{8:,u[:6C [aU9bG  Z¥=aK$e ;pR:5R`LteR']D!RFd21L@&xzYsiiii0k0rF( \юҼuGFWDެz DwvtTSӌL kCmiGx25('Sc"g?\LBp*/th(Y`0D͓'Q2E'@?Lf<Ҝ&1m4vdS.NHA bSgb*g[df'fe7ߴ(<;8"ٓSW$=%cFqVwN+Я |qRb}O$k>?'rkm/In-B۟Km_yoڶ}Fm{ ]6G[Ӎ nQn>#fI"]J*k>]lz\x@RKؖB':JMRr[D99L"BV_{L3qTztl!Fd.qDV610ehnS 3#Η9AI{B[L*֬ W0ܾL=k"?*a-jsVFQȓ;CZ}*rKK{bV_>_W{CBeZy2ɗkr`\+VGQ)I,6 I/U,,, 0G܄)g8D;dご$|eK;J/9޽QWydkQhK>yxzkلX5D?_G7V`n~_+)\- ̑imd"m .n/f'ǎl{>yaO4:{ 5x'c*, s^{Csv!+Dx+R{bV_ |"2%=u?@P]8(OeR Kc `B, $8t4'.^GI\\3:rZL6I\Aqs?&y1t1M{֞M‚/7iON:;wAo4r[#V4y+i* o_ݕs{<e@S(@~ҧ#GCds[Sgdx# &$&7_g[O  j੊,3JyYIIcCg>8?H"͏+zo($NNԘͪslEb|S…yFt==%uZSF715O[I P4r=Iيfpy9W=xǏ0_L|HMʒ]ʙv~!Δ.5\vi![~o}e~[ZK}~ϴC9\T7Wpq&f0`עP&F!F[VBkUFGɗbk%2K-98_zD>uQzȓjfP-,[G1fi$w,w(^b8L rxUU$nez vf_gq1&dR}oțK}EhZB86lY?;ف@9:Ag~lV&3'|M;A0 b0z~ 㗋a2(gZP8pJ0~@nTIMş;w *MM+ﺫ`RW͖0&P>S=([W!b7*627{A*˃-䵟&£;˗B#(H4φ9gf΃,Ks/+jk#z'4d9͆ϑQR繝T "y ʗ!ӿ%?Ry5<o<ޓ-E[>އb𨋓Qgg{2שF_缢,^ׄE 5ϑlJz#O0OQ[<9of"Rb(k1aRѯJ~Eoydݬ39x1 9vv*eug.F|/3?vx]Ao(UnĶr挣tVb[)x6Qi s>I;WW߳xZۚ!5QPu)TrE|e쑳b8d.׈kjʔUP.^İ?T+He)ay1?G5/+H:o( y }Vo8#@n÷/2vWq_o.b{][埚 s@L΅]b|2qGm#î`1EױlpVƹc&#aPRiq.^ɸ˘iI3s}$E}Qt &#Ӟ窐zL׭pû6'& {9.%3HOQ5ǜW -u]{*wvEQY4P w`u ƍȹp%y@si!O̤.[ϭgxVdQqp`FbbF\W'b& ^<ov)t3U/lʄ 5Zj=6vhProB2 Qe mZ#- Xfx? Ts+;CZZ~"HS&xãd+6b }3N!ЗF"ڑ/>EN@I*@Ks`@\ 5G,)^m { $nP 3㊇Z9߄hܻ;_qlL,o2mk+0k߭_VcFnTިlE.S oi2  <{bU_>, > K\.?epGйEY~ޖȢk80$|hրX "[&~WiHQiK©"i\nEGB>kqRGDqIτ[F:To x~LoUUB?¿gTQxqF/ }}HUvˮǏ :nR~|bk]B' jbDdff+K$dgymEEeŏXX8(N|gg oޔ˂q ~nk&b\?*A?&?%+=/xYVl2?eSB.]n,]PE#dêA=jSyg5u_t iS\hjS)ͤ^b )7̼sHAnu& 5qHO8>ı5h#KﰿDҠZyNGb *#p,-GPbv\l,htw6RSmvB]o޴Դt}zZ?%Ab!Ytr+5?5i TXe@勊lfkT$D !-jv($NQCA5wL䗄'z}ZGÈ4BY1o}ag~53HZfo*cW'ͳR ٜʰ->&(CR5>ДҶ-GHC<OM3D}gtoj3\7 :m)7k{@\x# ,nȡgbKb@0^#֞ݼp``QN#K$dNL=JD lycDvN=:S1d-|x컚:4?b~qft`qJNVVNb Sϰv 4sDHmE?ݕtw8kH"-\*zLSR/]i)Sʧ{vGAܚ*`­@(>ΩǏlGO2ÜSR/맏C[nҐڗWX(FZEm XW^!-M}Xߝl$Trەw0 hC%d\Y:-*^ts`'H A.M|HXB,(0 7j,/>Y"MvS.vuB"=zDOWDM pZZxP40:uWJNF-#\a!V<ց6T2Mu#wgPzvO䥋Dv3Wl'"_]>ς')˒%$H66z8ES"i 8^$>%RhzD9m܎U>Osg5}Z?wlV]~p 0fsG [{/W)75%u8 xKSc>>aӥҽ|&W/Tk5y͵w**zʼsnWq],dB\N~ (SÅ ;v 1+K4j|G>^-]xjO_{/Wvֻ.xXӱq^oiw.|=OӋٷXj #L;㣸I+X,VΥ\/'Δo]taLqi!mM4ci)LID.Yg0r7d󬽡hwsSR7݋/&} [\,2 yD^KI՜9`\8]Jx'">///GV^^$?ßS`[u9ݻo63,I]rz\~?ptʿmZqUxr\թkLƉ*g:J4<Qj.Vd-IgDGxx+YqΠ0OrgI QPX̸|BICo)uQ$e]<3I&dyOBބ !B$$<@@DOP@)D|EhJ HZkm>jkѶrksΜIz_>zsd^{UK:OtZ+DièdUaAm[H.ؼvH1OXJ65lJhʃ.Ymg6|iR:MMm2^%(8P:5FcJGCD9tĄ^y.n4#pH $j=r;e ^Тj)*/Xwuw80mZCôvȢEާ9W 2CW }pRf3.>$U0@KzE3Azi>%u;Hk D m{n}Gei^g yLz4/}+.B%T̐2$\wXFBո1UWARS«*$Iťx.ůÑDe c{q#T>=byQq\VC9Omo;}aCLRMh0nzw!7[!$YBT ipVAS4q')N@"sAȓ} -]gkuY9f2Χ)ך1)Q͑-EMK*!Y$){E%c|g8Nl>oQ*+nG jزeӻشbܞo K4EƬfӪY"3IMv)4A&q7i#5_|qmr# w6 q5"hY1hnT gOДx:xo-ރdJ8SMJi5l`d}HB Ѥ0z6;NyVUsmVL}ʦ&M{\wr-\يaoPOc-ᅍk&XDgjAq1{-3مs.ݳVL%#Bvo ;Ġ[us7bƯJ,L_cYMgSU8&"uN=PQƠi5ªBk'w(%H[a]u,Z^! 8&)]^ʞ/!H=ͣ>>=Aϙ{G#@>tam{ ޣOP+AthΎkcn\gLjc/ˎ˾D c*H75#NIfFhꨱQRsA~ ߘ:V;yU{KߚUK:._6V nlץڤ O.=zS{ٜyfUj/~l܂IdQHw*R)D +D!Ջ~\V'Rh:M$FOdE R΢iHV57hosίhVݖ}2ݓ,4mεxRWWQ~̿m~I7Tdtj _V7ofM~iE? -ZE䰉䛬ҖYzYcz3=O}&Nwϙ0.FhN&cLcNh}=p Ǥb,4pw4=fimREAF9A['jE@Qp[=,) tGې_U$ ž]&xsNnk4Dt9aQJ:8SRp%T683Ӑmy=j זΞY_#[׷,<0@US?г^qbH3E\_ ݱ / 5D}7uL++m]2V ͩ) ,^K 津No: gŭ8 ^ɽfDzИEt Ž1yRJJ+i+?OvY) >;д7{#|Mװ(gtJ[Gv-onlmF*mMm%VZHK;=XBVN\,Sc'xN-m,~?%ěhO(^=0PC{޿MƴڀtMK*]q X_}Ƽr9Nl#`uuw5;64ENnZuڲh1*/k~ .' NFR`zTeSD(6˟ S8^@vv{sTlTVMQX, H؍Bk4i ?Ztg(P\tMmt]s#oi59Ok8# 1>&͢idWOFG4'G~\6*@Z\Y7e=Aˊ&R69ꙁK gn;Ԩ Ptoq`^zuw4EZUyGIvZ|a={+`Y1drˢinufnj :x0l&X3@-%yW4*J dDR sۚ=Yu:;˙v}7敖Lٵs7T78KVY9gVi&7N-p+ 1=9\֯Y~y庅OOLMPBN9QUhK.!hNܸP.;Bs:K}X}x 8ςϞVfuzɇʼn{L[r+n S` xG2#61m!3(ځXP NSx]OXxW_u>uv1d>՞U1c]Ai5<Ěgc+E ᰏމŋ>1{۶{Γ` gTtԋ%wv:Dd& ƊyқC968qziޞW -_iٷ3i;uܸvĝ:iZNȘ:.H͠ rhD,.V"⣡H}u]Ӌ笨ktǕӫ}Д%-:|awRŭUWyFmռ'AG_*$C2 - ډეB)HVW BO^fFhFeWule9O)\xRR$f³{ɹfYVU jZ,%Gw=ӞZVKPH-pXpƫQ:Ys. t?[S2q~I{FZ_M2MR#Ro,B(f/=堩61pw;5Bd4e,/24_s 5RϠ(5JہXH33bMHQFZN**LBH:MAA;~3S MN~7.6֧k;[s~nvςW߯2ET᢫@OT^pOiNǜI\l%5asXGsW/x029oE9#B{y2`LQ?NxRToRujVΣ9T`kQ k|*4]?txS޿oGy.Fg494Oh?3WC<7V?a|{E;̩po`#\&z!wK}dnbTndmIVu L&y< IL颸ymF&$iii`,fÀ-!2gd)cW6]Fu-'YӼ;n{,T^k0&j{?}-[lN5͋fs&<}(O)46!ҵpMb٪+f2jB|X <ͩLbΕp㗈50.~~ExOR_;M#ՑJ4j)6\e@~mQZ\U,CiJM\NtTqicJФf+D ! bIׇ**<)mrkgUV*1.flAwJP'w?K֋ɉd Ad̘ݣJHG=Q'IPJ #^쪋TyPuK[`KOwZ붯KM]+Kb$Rqzk$a]Rp1z{֋+7yܦۯϭ"{֕ L CAenN~C%;Jw(3RJVNf.B80wKJH2wcQElh jԩtP?J7Ֆ)s}=~GM+fk^>tpX~}W۹ex.""bkҕr Cn<.1T WOP}a,Huѩ^YM;k=!l6-2 5$46z Sb"0[ݿ,I-3Xj ʵϬ֢W]q#^7ӣDo|:-Y| XQQT!p F/Ŗ,ZJIhk JX8 ?~C: 2~/>Bkr;6TvOAegRBEӊr˧{v6 xjhLCd9$P gБ 7ȺJ7yL[wG}9҉j~C79ņV8|~5ұqY3':*\'TgYNKKWDC){%E+!Q[aa <2\zqZ9{"'cwHm9luD1j oc_cL)iS *F/7^cCG:.¥_ Dꔒ):4N%@̌jC^enB9+6S@O7)k[ɚ?KLv&n>vhU "c.%V(սz 𚾠 :k nR?Ϡj@TJ2d_C1/~v)GtPt 4AԺ[6sϙ9Ys/[?!c.O%Fr81B4r*jzUeת|:$DH\d hS$1X߬(0} !JZܰU-7:!kEgVTӿ/(KG# ybL5S"laz$V:))..Na.N3ƼpBo 0#1 \Y7noXؾ,kŲ%#i:ٴy)څ3z Z* O g/XKS5MPT<&dff\ՠT=L]UPWXzdy+nmKe~~x}Jl3 PXEk4x] uXHDe̮t&t}O}_\Mrv~TrNk@ I+BxvʇP z줎\ʁϸ SP'`V=ڇrW9 "9S=)d^1|+7g}:^ @xꥈ(WY8alj*vq0. $<~ 5_b~cNCUq41ʁ //@hLKˋJnm``y‡]WkhY痠hX=,~3x+uy{ eq3j0fEfH3EatMl{`ӆ=0=-5ZSMuUCۏW3wfȑ۵ut͝۝DOʼsrL֯]z'4L5X2fZm²Rn*pq BD29 u*PhMP^Kq3z-|=/脗^y4r:B AQo 4@l4b+qYbFHuD,apm; ll/)ccFI5S_u~.tص"K{ ƽ SSKz]"czς0"sD9P3i5T4%$A@Dze4xP#!vViZiz?0>k<}&\"TǕ0yKȔ*MTˈ'fM@Iu5&Emh[|n'(qI*?LA9D–=*oQwn R@4=9E2`p;dlhEd* 5R0KssS>}Mڥ?sBoa7Q j5y:[ܮ19+HIL+Qbݸeԅ|{͉\`Xrz8U$?$w |RO֡o*ufW3l;c-)f<2.;UV k @Z1HK%{NV5=XϙAEN/M)+i~gNVzd{mp3e37P^IuR[YbN'gxrse<9O,tnbφ6.:kǕ2ט;A9`'(6V3?~Y~=zE)ons WT8sbbǥ`VلBe1~\[š7p m`^+z-wF.󎣦4M#4E8*5h1у@w;MM3}殓箾FFWDbl%:EL{(˙ 33% ӷI_O< aAc . y)R5O{ HIk[V˕UUck7W{E?apI=S֊(u/:J 3dz:)$ur{p)sNW3$Y>K[jxUșUlje>NdÍK<(;8ŷt3C&;Բ4LMC{ڇ C }@{NQ>5__s{ߺW5"ے_:ޯIj? /s]IIbK Jg Di0dMK$]f+_dԮ&C}֯gdI2F?PA貔I[orQ=ӍN? N9%7,)xu2?~^{iUhmGwby{,;/'& :}֯gbS-ydǞgTDkІZH`N'AGg}NbE zy+Yqn I1wӲ$wU̸EKC5. 5/]kw,ab1Xk2-QɜDӽE>Kg,M&3eҝ2Rb:cI:vhjoicMOz$wxϰ7-4̬4' ^K+FtCT=e ))Jցy*a5H`z1:{ 9{YC}cW:jnzϭչX04f~Jfps| 0V́Oh/D7Gq* %y3J CgK S )֡{ N^>XX4L`~+u =PQ njv }oiܱ) T** WO@^7`]S }՛;/h9/Г0C\`W N&C"m ϛWU5lCSNLla_֭88sad"Fu-ΧAz*'DI;R=GBl|sq3ߔ+~ewnO{ Wxc;9L>mC4)h~ZAtZ>xH܃nLs&dөRru`3 `x`drR< ӥ-\5|v8C5-f[ŋneIdn k3-=a{d DҳΖ'G~ n>>QgY"{ɜ,NN`dv%uXт‰?x}pψk.s;bnZG*TQ#1db9۰-d{ƿg ˦!?G[,X)+&Ydgo 6͘,x',^$`Nbw  N[<|_-U]\v}շw%#q ၉ >6Q-ɹƠ%9VQ9j)Ilp\N8h8N.Rk)f3V\fg=^6 L̹k-ܡ'co;kVsk7 ]fŚXx޼9t41B. RQc t%כL:B1a۰K qq  `)!Zӫ-/Yپ*+Z@ŁE]WfGƉj+5QGA jT"cڡEwL6l Z'42b!N!`}1^*uEQFNdhs?OņEK-_bd9|osOwﯚ_ d~ g9W$MQðDĚh[' P/V6x.-?`U=1[JsQ\ɪbƭ[~rO?D& h|iH s{ZCgSV|CpZPE3,:c{zPiUjmhp" HkRܠP '` E^L?sӚm9kw9 o]?P!W;:^}LKk_n^sjw6ܴg^}]WwtNdAGXM8Q`SIZDMx` C29e\V+~d,]'WUJr?edQ^ŽHpM0ssּۇ:ЙY/=.-\12wA{~@mD":\5gaU67+3WonܶݞGjy_;~+/F=QD|"܆=KT\0SDj-f)6`{hKwpcNj 8 ~_|fD@cD fNж %JOà .;Rٷ,X8gf[5׶}aG?E;Z_^mʲm#gUŕn#֍Ͼ{4 Y\oԖJmz3geJӶstf2H|Fd#eϜ8+bi tx㓇NO<>w}B_d^wJuu.[p<[XeFmYPiL6̉=~N֥.3P/H(wH-E~!ԃ6W 6 IMrAYXcpp-_wh΀,AYuCm^ⵗ^Zm>nM)P7yelou 6~ )9ԮT6ZWVcam8Ą\GSBڅ,#{^HClud:ud=Oe!Vi]PK{t5*Pȝഏ! ܛsRtP$4 ^ 5];'Go[|Q1|c9F*AtkA[}cKjj+9o9[/s @4g='~[Y9e3[ގ%莦O|!?0ȿ&YXju9TJ]  T" `|0ޘ 聪\qQCC"&8S  ZFD%{奲$\`LyaES῾uݾac-:Գ>vܨ=DO' @.c g |LP E#Q v 6*frZѤUCBSat鮝%DRP\m5d_BǷWaq:nJ%U_So!gt耩*| ښ_N"ܽgK,/6!I(\u_a\PrrG$q@B]Zj!_5l4E$NhLg6ΕF@aj7*^8QWdn_䗕BЀ%\\}#܍7\ߏB=h$d#H{+7>~"n1VkqSM{fh8J_M9Ѫf^*-aKx>;;nfi~ g^U-g> ̂1y1ݬMjG}VjŦ""6Ad3hX%I[Ǽ[Qd D%qI.ڱUdI#h͗ [-Qk!YyZedLD 'A, $F+h [pl9?Vvh\ۂvOFK4bZ6wGJn$$- LJń|M7 LH$K I:H!bA?27 nZJ8 x'W=]+GFF1Cin3)`wIsQS[fc'bMHDuvd$Zc48x)=/FYsq{W ]s8c{ȝք3zYR:LYN\R&$ML.C:DhR QY<>i(NMGGK #gJP*wrP(1<ž>xF8/H"5$k@? X䡺 T"Y4T\98/b28Y"˭>ZXh97柬[?ذwO`>Jq>D64Plh):wed'@[@BzYX' $d?3nCmnعq'mƼIW*Zr[V3L79RZ(KGX_$SQbZ$`N?QSlq:Mm?*W7o=b*)/$xhjWa$2z("Q9`>eOfE4gڅ1 mVh/hC4!YQ*87RR⡍^ (Th$-RuPRQc24D>i{INߛ=ܓ|}=Z52kЬw{ ??R&$%@lpP%&4.q縷Cz y4ӗ<>cF4sà7@d2`J3.;!`gwlyOϨdԩ747S{a Fbm(:`j lh| 82Wd"(b֊({֊`~YYz[[VZŋFQ+"湑Z;JиyZSHi7Ё¥* q_چKsL-tz2eag#*D @JX'8L񍣉eniA-:0W\qJt9̜_՜l<8+F|zBM uQX V֒urpVJԱDK%Mg%ƢpM5TrR)_doa.wE:#xE,|CAaDpp簚F&\t4؋ %Fv嬲,[S3<*/"pP(-|{ѳpu:hD?Jʘjܴis}c$Sr,ՖfEKRkL{g?<Y:QdUVHa ƽ:Väu[ _$E.oZ9m*1N_w ș2^>+YRFҐ O Bll`8* j5ƚ(# i( e@j?*|")3BxcDiSX F߯ㆺrϴPo=] z}|u?WP6}{U:/U>t;6Z<\;j2#B,;ꬕV X'G^bHOOTSK/+5V Y;;`Hc1̅V/vT4n{Ѡ&޵g~[TTo fcW^jQFTF&s֨1* Ȉ˜IIl 25ZHe`PPXi4EKN M ~Rk"BH| ʯ0Y>#D bҠK4$RW4crf_>>$dpj3&gq \?ҨHqŹ'hexeQX&'O\4Ȇݟ5BDL81*}a Lq{ܓV7u\^p2Lb\㦮 hwևc}Wb:DN/{Z(.E񃝆R }]q^8**(1r{-zAa2D;Ƴz֊%:=>g8`H5`# Da_o*HPlqCGb)ؓ,/_VxQ9|^8K&'nN ,,k4"׍TK洉b9Y9&(oZlgs_[вP]ؓ#ȿz¹6OAW[5YwdhZI,",O6$p >:"P4@% y3J8X1MF]𛀸)z+lV_G W/8ߣZ{*Wנ[;wgn;gi||mdYd t$SjU7 weϮ눎OlܼXO]9.蜳XeVtN?'S.?F^@?KuܛϟW)IYoRo+8 ySSFye%୴kn*S8ehPudhBjT ]SRͮ,.h;P.. Y#Ͼ=СB=mhreO:cv䇝Kv #O,*5|2Dlr:ҫ)}`?A-na'2,AցFq#V>$^ȜiSdOoQTlx<FoYhg"wa _VUM-gkOXqYG8Hd,q0~=Z-` < O3Y;%<&ORFO{R0BܣH%.~ne\c?59-]1!]usBieW\/ h2A0-Bb5'_C^Cdy=K1\DtkʊIEmmxxGqi<+_8}M)p)myj Et;KT_S9).+-_ꆫznz01<*a>2蟓EeѯiW$(уp5Dĥr{OJO$sa&րvl@obg~8̳ԢI͟R6e?Y׷w,Yl %]FdP0I5kAtIzԐ+B kr dJ:K-6,NaK6' )FFtvn9}(/΄:io͜6mfL2p!ܩ3d@xN*FvƜGBgN> 5LV)3*6蟓f?m^z; Qu@8{s?~w^A=gO:T96A̦2?b?QN+jP{-x5N 5a_3w;i& Y` k%R~0~W wy~dowh;; LuQȁTrƯ@-;dDmpE*BKV!NK9mBo> N-'P^bLҨO=Y5)Krt56u'GψT*“Cd<vddhttVף%%J6FhIdSmfRRK6l42fȄi2 HQ^#$L5"g(o${F&;}?|SZY GޛFUd{Uu{O{'N{7I4$@BWYDEDD}WܙqtTqQQgFAf|.0<(N]v{ot~Uuԩsj9e?muuo5bĢKFY60\y˫zMrC_jׅ93Q,h#}cǀ$wtSfМǢ\XH>U"İGta,d>Cfc-qF%'[@`mR!+V^ܳ41fJi\færqyEDk=gWQ7:D]D }̿eg?7aVΓر-i+Jixqz@,yN;B.Eq&k-7;>қϹݳӟ+ƜYga{iY?B"Yg}ڼG,?;|)c dl&f#l0+kZ,:= -A *AS+]i[%nOގi]qCCԙp^5ogZhk W~G~kiXLC/= KRTA]jڬ&[Sꬸ WBS0wђuE/0#!Mgle!?Ҫ蕖5/\/HҬt!҃WȊV<%seX&Px_ǚEe9B˱Sb#qGxNXY4uoڶm6=~q'~bK6ۛQ}?NiUi;KV|/M0EޖMgOy͗n'HeϞRwy'%+zԷ/.cd-&6(3\72߈JV27aMTZ\nJUM;_U,D5g-|pGH(u9~zDf{et+`=(y@G DDѫ|¤R28ZZDUo[,& v;=/)ddKVۉV]ET{K-~位Y5c&K Y<YGU;z+z*X""T.mYxKW|5pEU cZ{Ȯ<_- yA>\|[e d9t[e NVق!*0X0,]NJTᴡr+yG=]v]ǙgLر;8v\}0P/W78w2MAT1=ib繥ȍmm|NGrȮQ#v}-* g1916TUx<%0g(b ar|=\jŖ%]gySڙϬ?8Ƹ۔߱npXCq_ރ/4kFi3ҁ%Xs𘞗*8iZP93xAt ˞εqQփZcK3rC%MXr>|*7L" ٵu-g6g>6%69טcЪw] -]}qn_6i^S{u{uzu/)Ĵ.mDK>ٻwϜGwO^ \V6ruSf@Ϋ=n}¢6{w3]lw/;T+`ʺoN2ǀmQBqa/-6v'PN‘"q^ 8~Tqxva(ZhaxəqX6U##[k:P Uq,er4{ s$Hb0m6PG%Q Yѐy&x4DvΝ7bTQ_};tWoţZz84/E1?z"ad{D/ #2Oxo(O\oOOlPa K7HxϘ:rz%,q掜='WQWm/t㶦у<_7 >߽?Ջ ;AYgCGZ2ݠ'fw54;v` .z; Te8к+lJAE5;0wQjZ!y| ^KA0I9tRr\晢MWK1|sZ::PϧTK|GAΕj>Fdb#%0.E42A¬>(k@AyɝRgmTOsW2h^~|sW2x-(K}w2`5aU^ü^׌ՠZ()V݁g>>38llwmL2 kgċ'Fw8ĥN5tBf0d4&iIE)N/SħL>îQ>lnY[Qeqwd3>w­7P Gqvs\]7dXg8opiIg:Wڅx$:pI ToZv~~j{k'f~ʼn5BLy{>ʊ.'۹vN1/)W;~g~Y-=Hfwڅ; XGù&d?A7g?~`vC*VL Fn3p}!Y0'&\0e̛Q 7pٞ9ȿ?\ff_P̣ ykh W䊘'5)#셲v_h?3O+Go~&{M«{-.ڋN̜o21#fyxfbWlG7~ J~`d*|"PI*|k_!T}m89+ѶRl;9?5} _Ƽɟ5癘AS?cƐ94ßdWe[A5!?kP;&d(Gof?N??07;xݍ%Cb{}9g œׂ7U AM AD` ]O |H>Z:{Ag*EY񇚔OoQ?TW,׃H#1{?k2C~ u{o P2|.;KNfer4v3?Tfnqɝ93 ̛Â9_;3*s( 3 ̇^.DvAEJ}]_W.]H_w*v9|]J" T!rJy~ 7+v9|Y߸a 3_u~i_rRY0?++.Vk1sx9e'Kh9SƃtxNvQxNRx2{B@ݔevثve2̎\SC`e`(þ*c},}M2;ki` O~:>gI`PCx_{aP|n{P|~SA4+FEƫW ,'vev/2Ouf`1֚=t ,ǰXfwd`ea_ȎqV1|ƽxď%*SK5T<Y⟖%J'ǃxyduR2e3LoȎd`* S`d`>1vT)X_d`e=#XQIz7Q8[U!~, bLtґ/=/7cN ed2_'ۭXMϏFMrk E8y_Ʃ@b+#@"2>R' Ԣ3h7Q((nh C&t#\@=s5_(w Oz+r_r9a/Ur01Hqȅ`V z~PPt)9RDo_0Pk]e( ˾\)P3wcdU`xcr:MFS՞4vW8{>nDը'ѩ5Ew Z=Vz\(TPP:TU6 X())) d#Q%ik^gɧ)y8j`̘WW8ˠ =_ p7+E:Ie:*:/X~u1^&aa^q/"d7،9ϤUs®Fq-Аxsڻ)H_Te9#h2{W%#KFZ.4TpHU):6%@i}TU ]+h5k5WqXֶIbyWQ᳆<)'hxvcc`MÑJ Q)zzgPe<~&R]њ~v.^ G-]ˉ_y *74Nh^h.[*Jm}JͿ2 W06V|WMó%]?&<ц'>׀9ؠΰS](tA675q 8Pi8 ^3/=e>0m$6mx[KS}J3@l1hC ])_F$w3KMXGӹ\cc_d?㵮@$5GDWq7K*9rq.o.NjDZ$U8y>6t%Ƥ:*󉖽G \;դ"DJb)}mmjhܢ'ʋVyժ\Iksxr͎+š٥BXI`*ŒыzR_YPJz fMh@ hvG7a@T _Wg'0Vr;65[Y[;&}hm}.4u3/y6:γI6-}x7[ yB=DR=UF3*wr^a0fSPzÚ@O5LG+(L8;0dn3֓3kxwS_㱃I_Ѷ3&Q4_ jqӭ~{*1|Z"1-J{h3$vj?[Q܇ڗ zK6*QBORsx}Gh~H|sܣF ciee>PWBƽ1կ Ai;FNցNUȵ-'j=1J^4|ڟgrEAbŘ,:( ʗ~I^T?q29 _aFQ}q-/*ZџWAR0y{Τmlh֎Tv$&r'Y,sc+sU|jL O8{hNw-fs&O64Qt|P(y t3:pƓ'$(B9wZ(S3 l #/1ע"ėH+GtejK;:LJR ΁rQq0y*ިhG)Cb?h1ӁFLΙaMmmY tҹ4wre6ҹ)ф}e1WQ+/b<ŧؗ+/0FأٰD5L"4\k煣Z,Ge`oi~2MF1^K|e@*_zC(1/(6(_eUFN*iVSA?YLG9h{cAvMJndP/}:j/ӻbj+;)yHRAjž *4:7{ IcgH~)e5/lCO442LFT):FI%QazH$%(M[%HTUn&U|b6芄rEYUie]k/qѵtFo= awٜdr:GYP:)ښL1i5"F2dPjǮЩEeIChAD߀?m%3,C}v>(}8T5jjߴ}@Ƚ]6ԃ= C!&\(TG$C5A &Nm1szZ =j`c:J6J ʕtȒAzD4*nLbnNjh1J$tԶն65DcњrO{.jfo)_Q/pR\ PTΫmc'LJzb"; |I1c&&vNouD`Fޖ߻woS/N?yYlG_,@L=]Z~ob9/%VEu[js_xafu⣅GOGq> BɋG}Ѹa M lLlnrĉ 6>iЅ:SsIEwLI3j M3#p HxB6AB#K4k~KLŇ/Ϛh g 6Dzf磏7ߜ-=@AzxhOo]7  QOp}jȹ0M?ꣷFB,ukN]1֥=MSEpZ>wZ!͡|S<1P`g?HvA~ 7#,cE<:1>spz 33JL7{As3j}C֨RzQA3WNHy_f>-ȚTS) iM5!=%D$9d?Z#m;EӗIHgxQrᜒ-s᫜#&9: n yo˻1S:FTnm^?e^TFz*(a% Lo9pcS:!Ak1F%hЙ07'Ck8N3y @r8ZQڵ0hvzgqUc?24:;cd߽mϓJvt?nh4ĕx_L\Հ&ͯ57>0@Bj."MXkiSX3Ѥnv]bM\gYE7 ['z<͙144Gȿ-YY5՜g1uZ(f/j0OMelȾT8GLo^W+s:WYȄ8L\w o?֫''|JފjFlh݈흡vuM5a+ؘ0槭%}cMAf( Aۇƞ4&A5,ȞH4g3PRtA<9|)`yBfET#pl~ݭov?W3̂Xx٫]!uF;G>)0q,(l֍k=e.,xmkW-nԥ.kkn8˼F+T9ֵW ,5~K_r9vRXp7doMwvfCWWCcgw}ςk!ϐ} ߉Xk@$cV3uIU*o\|V?6*q5%Fwf5< g'ОhO|g.y qNFhvuw{.Ok'_t;}Uk~őҿ}k3u,zs^|v&M c3MYG#YZ2xUxVu[|~{i,豐?)zB8g דez^QXxѣk=5ȃO$.?8 #v3|2I]qMWv<3`2^6vB<ܬ`T{սPN 99ܝJeH﷤6hSF%S4*"s97}-^__j_q-6ɵ`H_/&Mos6h&*;{5t uP`s–<0֨ 0yJ塗޽vZ;ކ}/>>{]M o8:'?h&'R0RQVǂ*ڙ)v45]Y0}L<ڰwPK A TʇE>'N`(ʨ@קTC ^ { +/[:nY=g -JU\XwZZJ4kf^][׷z% ca9d9袚'TtE0x2W&#]+M-[kC}+ ю(|O e'rsz5*Z|B):GcwKϭNBw'/9{M ϟʾ6wBt=|ߞ64*`?>Mj& rFmLv|d@ =k!G[l.:\P,!-~ 7G\W<zY^c luL_N _7fb܂Ø"Qڷ-M҆p^XP`aBC0Az ! s#Mx>9i?ŵ۸ Xx#dP JL܆m|C7R}^z.}LujB_Ǐq_FZZoc1* l݁ː=Q'G>kQHѺzW}>oT$_曋Xy*~KoKG3 򧧦t{YWbBA'R[ZP 1UcUPN BmhZ֡&Jدq+̞>>QW:jgD4"B%\9>6A;jŅ1|;_tFii1t3 uuӟsh:ci ӟj[m:rh4UŰNc+qBg|> B( 迓o/="7Ip!jPoP7r rC.NYCrk2p$RoR̔ӳ=X::o[︎lO(o89Kt0S9zv BM^z0 cě ?.Cz. 4({^\w ɸ)\H;#)d2?NʎMO8oK{@TiR;8$>.^fD;8NȎ!W9&h V~moOmǡqsDˠ`4,\9?ӠpR~Tv '_[ fd$g鸐w82I_|wܴR89?AZ0|a2'lQ<zZ؃C9P%GagYsQQ>C>|\@+§h\A:|qӦNs4ip"qE'6Oz$~h`د$SW09 uݟe.4|LX{&OnO Z~푇Tg%4 'ᇤEDX5~MW~ !'D؃i.al0&SђƟ4q9*OҤ P&=gw.]&%S؃i2.5g6xBYOѝND~8`Y<4R9Da/h.0D ͆g]R7 ~P@j~|~ݷԵ–POѦ:]¶Ȇ]hm MlI1Ζ?'|C0s *CiNcdϤl_2>-n3I+ac . :!ҜSAgXl.řZS&KJR鬙@~k02m/]) HiTIITRmɌ9C'UiWb6HrzfI0{%446YˑcJ[6669uɣIym}3cBic}ĚM`p,%޽RLcomr'1mIw3C̜(6ua=6 qb %2 =ɋ(/rW3kD&I/N6t1Y\KSrJoYz&T4 :$+NG$]HNH5 'lݭ i[nEv]:'9yj \XP }k:¨޲/ut},)p(*wR?`~NUR^INP.Xbm#SwdȾI)'5GQV\HɾFF%cgO蓓$wH?~gmRk9ljiP0z _z5BM7t2'3Gc{LAC a;Ľ2'_|&^x5>7%x_o7]>|?~?Og:~ [!ῂ_75*~ ?}x/~ ?<w;.|+^WeR _ &|^x^x6{ <Oppģ*N7ǵx8QA^\=cc 6\lXS`uA?:@?їs 7hߡߢ}+%z@WKy3Ђ{c z݁v[-GFtZ*t9 ]t!ڄ.@|yN/x ۷x#wӿY2L%af ˆ%TUF~8rwM=UuvźkPdM7 + 1{5"ހ)By-oE,EBY4tpAK{ >&ܝW c{i{𐟥?g4©])#H4uhzl4-BJt6:Ɗ aܸƐ`<-w(cs~ ^q5~ 0vƱ?g%؟g~:_[^+/³~C{n믹;_7WXdg9}'N;}T[kK#3ze,z醑Y{̉|#wGϩ(_yY*O7S$W.ؒ`)96:7[8$@6d 6` #)1MBr>Jۗ9"*L ܻ4EΗ}}}'f铚GÔ< ºśxJ`"Oϒc2Z`@Q"(p~Z5s>"/47wܱK u&0Z= oCSI&$*i$! kzN%0v!`R=+־zAh8y;#| gnD\*I0 IE Epiz+z,TOHZ@\+:UV=Zs ZtmjУ/%MQ H>ztM(C0W1I1MG4y,cn2 oGoZt}2G (=5e#"q#=Anxڛo _&6w&Gt^X}DOMK;xnzM]ȩKMe2Ks}2'Y^Ocz ]WHZ;/ XIzc.KA: ׬SBdEУ;4.C̟1u|5QMt"!Z0E,t]nj])R(FZQnO}D]jۚԝ n JWwJ;-5/Wg4iF]j68:?w-|d&u;yF:ջo:n2iF]$L c+j==1Gns#GcBI? h0r,1۫vY,PE-E"~TV7cIDzoRe쬗qhIoGy FIWt;_d-GbSSW=qU36LaƌS6ktϘ@[;\D ;SYۼya3|5-l 6{{EV/#0x_rFeE<>2ieՍ^#weӦOt4)RtMGN96P }HqYU\Q9X.uBEEsM3T M!U ^=YaZVQ=@K@M$圂lmk[}Y଱ /^|˅ 5]'+B5_}6_a' RpbOՕz5h- ކ`uCg7/DFg^ õ2! } yJb2T"y'vOY5:m o2K[|[?NϟNGQX_S: ~W'33eX.M/ė(`otGB鳈\y2P)ba4O$?B~o!y QAVx*^7‘F|>x< 7aPZJpVz΀NK\Nh Dػ5`"yWH}ļhk#u컖j ᰻@J#MhMˡŊ8`Mĩc (2>@Pj% 3KK]!V|;R؟?PG:! ӻT@K @*6^ńz`lJu30 S,~+$ 1N՗&6nάTéG]KCKzEco6Cf[S~^K 8Jƞ@D-mQ\v{T8O+߯s[nE>ʐDũ Xr5hU*fh=/Щ,!-ѩjU^QkaFMQ{݆q chs&8lqUdxMjMe2j\M#`Jrz#-zm`JBUNǕbrFMǓEނ\Ӧ5vF\ܗ1i,\7X_uXU::Pi /2ZlA5%֊dt*DU8iVaj8Gj+s<6^?w%kts؈\# }>E;aW(WB]%z#B=` dzCEOh~ dP&:YE/€ڵԠAv;Z ;ԀgS}mU_WJ~ 0.`nDaBw;PbzaFm('4c֔uP5Md<6yF]DFin7Ɯ*i@x'E#fjG.xGF#Ώ$/8h$ga4"E^B|BivSt8?'rT`5XIv%b'srCXS%%9.BĘǗj@RG LMp4Y,xݼ$CKxdBbqxk 9@ B T\dApSsE*,Hk0F<1fb@6.׋bvM(u,QC7 TX™Qq:ӨyLc.֓悥Y^U,謘&!A21~߼qcѬC"^']>s=z[),NO_+GV{8/6T,o_W<!hM8ޓ;v{n]W+ޮz~t0๑=tlΑ؄Oű{  8 \#S> !1C/X##`@(@{|NoRQ#= }g |6SDz/ Նaۀ(ՈbHtRƛg'#1dشM]nӖ=vY[=A{YH[-NxDÕTFSSqw@VET$TjQjE aJtEĕvo]74]ޙiomjHVURrZdvKJRiM/ϊ>~Л׉!!5T'H7N$iOyAHc>{nwæ5kRMo\]WN>{)E^4-sF.|զq16_v6n]O">"\xjc k̾'ypu׬IW6N$_1ý,ӜexShP2>ϏǺ2v9>pu.ĻV[;5۸ݻ+c fçO56\㊦LS**ZO,%dv^+QV elG7_שj "OWMp^ ԯA |ШdxUPEq|u/#S'1>=Ez</T}knկU뵾v_oU3C҅.UE}(?@ X gc^aQPtbP x=&a-exE*be~Q>Xdr3'o:>-_^I_G37A*/D=Շl!Ȉ 6zHUxTLWgʦ+#lD`WɈa룑_~[8_~4DλBedp'JzDh dpz|0Aک#S gЪ(CN>l%*Lz.Ov5DC DKGKr ]]FCҢܽY{bFr 7uxd0cbz:i w.E*,7iv* 6F=ͭڕ{Fltug;􏤫&[o3^մ1*Dbgբ⦁Q]Sw~3Uj C F47aAI y:<^e:4HvH' r!?}nﭷyaz&H eB:|Ja9^1Xz#^p S pj"rȢgZیSG1}c+2uoMoCS;]νm~_!{%z@Y@0",!H`~sM_ݾRu9~AƦg1)l:;z:c0#S>"C$I4 o=#+ܣ4:'ۗ6VҋHZ5̝YUL]k(|8뇮JConH+smf}Ԗ+Zsw8Fږ# ցR)Z ˭x RlJ&=37X0pJZmjY;[7r6ռVipElfqXU|ƿAW*"䉺~*m. ~d0з%"H ÑJ$A(tA> Uoͬv,t=&ݠ\*}(T,fkX^biL7 V+ pӐRl- $ ;Q) wC>BQ$@bu&VU5t|/ž>^q+ȕnN W&t=_X M d?^ud;Ra%)hHS+{f]^gm b_Pj>7?ãtin+4‘ aM2;?uwSS#V.s`%-tiZw B:j:a ȩ+A56 I cſ\L?1J9+dI Jُ~-i DovmT}c͢,b2{{LH`E Gػ3 \pѭ'qxeTo;`<({5QdUVF5RU# .t;iu;Ȳ?:=tNOgod,l2o/56w$z жۋ2-M N@SYs3 峜F!3|_ݹH5p.K8m&H{;xaͥUUxicm+Gsp.?sVWFt:~FQwyc!N:QxM;KZqwV2 - ~Binb"nT38ZLx1f,3?Aw+onެmI+^mbs,)E;Q|BWf9hEX!.-MW iDnXP)5k@99=lOoˑd22%!RJIIN]hħ1nWn2j5+c<mNm7asQAcDŰDb?ϣmڏ) Y^ZGcB~Cmr2%OTygh7̣ 4#ͣDAY-'_&Pޮl$[uPֳ{o!"ce ʋ1Lt(W%JP~mcetǹI }:v6v+{ "a-s N&5}n!b@؍{͇A4-!{!*ju♗龾m^_ͮg~?A FqF Џ鸐>} [aZhBA}>i|=2;>(aѝs(TJ!۠de /A'iD!kgm@߫&\/>V5$*n^WW?j/u|D%k _%B[T*VYq'ʉˉfϧ`|bb/=\woq0p edv3Y4H'8+m [3sd3lLGPlZN-s-0sݧzwUkkoov8n't:M{e}z|Hvr+N!ؠ'\{xZ>ijKѝ9:n44X9*k;uhW~Q꼎RQ4gpvsIQ%'6^҉s ws"(bX[j*4` AB&*+<$ بXA(D@TJ7|iwcϞ={"ӅW$@ct,%Г_;[el Ҷ:N:jK.='9Z+u ԏܧoKP0=PǤE!]eA\Bnr=ve+tOHwR21n^26Z2tz-DtVP*8|t7Em߬f$_&jA<hLC(`յ\7ot%2H>gY2^SDbt=BI ӽVnbú;Xui;_@J {LϠTwIއDbǃ`)X'O_^Q~/{EcΕ~^p)hyPkdV2 ]')Pp qԀ}zHS2cq3OS=Wf J{  mJOF!ؔnfH_G:ɞJۼ"N?&c#|*"=k~7".9Z8=^QwJ7+W/[?U_*?d.ŖM? :(׃#v̧M.+8˚wsJ_4|6~EԝӚo;dx_r~y7}A[|1g_J?LjLY6ACC_xErFrؙ/u@kuWfM1vgn-^ SDA<ϑ RwGY"dJ|L}:~l3dd|d6}BB+VLC YP&t6kn!oӖ݂ϼ(vnN3> oMO.77|jK; =-È흜Op74W-m]0Npw0ϗkit>u/?W_BwX^7n/~owkTc*.t8ލ{yd]dYF,L,^xߒTzK*簃 sn: w#9}l+NY L4 H??x8e䆓覈|7lh:z(:{#34 l.ഋ=[X477 7kl~Gb/o3ckʱѳ|9:~Ԣs1{/@['+Э:&]С&#O~(nX\%wq3ñmwE`9sW rD;!b$0 FV3qoZ9x8V*}/C e z}s(C:W0/dž%[J61zߖJ8X?ߡZk5.}O"j컒*c8ݙɴ3hsj+ {ogho;cR磝.|e:3ps֋)lQEpC\!鈟yz 4\4Ǡf=/}ǝ]#z#qS5zϼ\s_cay1͑ ş$^u^ޫe"è-]}W23}$n>$mq|3bQ2<ޖXѱ=Φ; cx|m=J/ʍ;:#Dڙ@{/.߶Cts0AgC·=rabcȯ1mȣ?&Å V5wl"eɵ~V} rMăE7S7rQ ׀6WZ,jUh)WS_5UONL ]NL|5k.: 7=ch FG|W;.omߗ x{ 8Gb>>u̦7h\GX>IIWWtPp*ikEw 7>49طKjO^krw!v7OȋKv+9{0`/9ba|u58w-F v i8~I  Xn__oM.$nD,[E Ng`& _)!&}=H 0Œl|Q2t^ì)uܷ]]h1*8"xYdžџ f`7<[ꯃ'4Np,7/NwH|Gah%7̣&[&Bhabz0P½fas=BmLPm'ɗL%AG6B{X2:ÍMRmMSڣ ^ԊݩW5%}7o.8[?9]k}^~ m!mx_"H|W/_Kp6u({Wt,&{=fzypa2W$ Ij9r{uw}D (deݑR "nuvԽ5|J*=hozȹJNjǽgEqԽ#hoA%8v#keQ sFW|z][$< z;N, ۉraUr|wG&{,*`qT&~~\0X; 6¼P{ra7]An;kxF%>?7{_qͱΎ2_6`{x]yxWUthe!!aSRE< KJUe؁$d&T@@ K,Ѳ ;)m@3y}s9[#!·U!(,%[ Tuu]Z7nB}gnWo SBvgB~עp ߭5rQuI ọCW{KChJX1Pp7i pyCh frx(Q $aM!4y7byT(nCCx'rpiۨ m[ЎWq =;ӄ/CHBkօБƎxvrS?Z]p|V!U~j$јDcNI0`'O~_{Q_R%^2'Gq8׿ ay8pp^ 7n#HivG:3ҙpF(5GhZFz3Z?Q c{scy=\XkF+gr~"}W}qtSc~4' < ?iƣ4}NS#Mt>gГoxfgxfg_g,3T'SLu2%Le/,,X^2V{_J}ZwWZWgTGk{-ί5kXG~ϧuz/zyqA_7OF3Mjmͧz?⻙ݬhJVJ5+qLg۟pbFҽ/[ mcsٮvvim/w%g46UTu3{{V3t<>HAssqP_![;b{gǜ=8oNzJSjҟӸg5fݟƟ:ϣ| ?~fKg_qY:ן35 NjDkZ}u}j\{]XW^\^5k^:ofiBi!ՄNRn+օ!յvkP\ QBTZ8_RnwFݱE Q&!ݙC0+Dwù"Dz qVPX|Dq!z@ރ#BԴeU!zhQ;GQs-\z'wt{6-m7L5Q'NΝlsP]>&Dϩ]C|z5V[+8vB 4M y#D= {ѳPx|z^Uoz;N>}aų/~}\G}W^?yO^?kI%9o%q?@Az?fd|0<#5F1šhDŽh >?c ^ĜΫ_wx9o&'d2s޽! \ZS_/s0_a=L'[Os9H-YdsH;R4v#V30z7Ls943̈́ /ϩR~*TRaH# F4>{48ipI'70aȀASMp2hʠ)eГYpfu0f1KY54 F9L8p2dɄi>`dȂ# F,z' N6l8piɦ%V6lXٰfÚ k,6{6̦۬'lɁ'N89prx˻\X].\xru.Vy䙃<癏<5;%7WS|}ɗS @N9r|Dj/įfY.7LT9s̑3G9mjUs`.O[DGw@ER$Ez[lb=)Wn1/aXb:[8ϯx/5w%Gg %pK{RT~y}E8ן/T~-c! a$VE||Z]lrKiZ9]Y^ʧƹ25`yy79W\2|[2:ѱ?VK_Οj,7G +y8Tk%} wëpX*UVӳjV[_jV_mCk\qg85/_n~r?7#s{c>F`m̬ǵ ^UQfB 3 < c?1o jli\T sUi*a}&>7ßOނu*w+}[Vw໓Ɲv݉N=o]vn:#ޕG{QkGxrLc8w'`yB NusIx<˧?Ei{i3ruΘ3o,z;+Ƭ𥆖~՘>~NsjwN?sg| fԸ5.wiErEվīK^r}-jZSeg/|e5[:UpMkNu^_{]Ͽ>|s)B71E,!=DX)v!/: b o5Ŧ#:n#ԼICC8u+CV5Y!VOn=*^R>w8wwۿGܻ<;w_FMD6FդX6h, jkYM=t5Gs:#jkz<0׸E,5^y<;`˸\WGq !#:! G0n], 2ZpS<,}#󼚫Y)} {ήӞykxuOPI /^P{.6-9P4M?ϸW$PvTLyO''Nt-5@_ˤȈӐRN~Fv6Lr OH=1Vų6Ϫ~ntɹ~iWۋ6k>.Ug^^y)mnʏcmSI$BӍ8[ zϕRZymoMRǣKI2Ps(Oz=7Enu֐5Io%lpxf[`+M5zbLNcWJ6=yy8TYYhu(2Y;Nm[V$ݑks)k7WUtA "t[VJ궷`n sY2qL&*8J}: s^Xۅ-9UGFRLF]RhKWo)t}90ʨi6l7?Bxmxֆg9c*33^P^LӤIhkf.pm{g{?3yϑFsRMYg^hE(ZTZBvա:(5ZQc8ZJ-Q˪jZIVQj ZKQjHm6QզK;9zM{yݣ]ݫt.\]e=B]zzG7GzW>To }>DӇ#(}>F$}>EOӧ3,}>G "}D_/ӗ+*}F_&}Eߪoӷ;.}G߫!~D?ӏ')~F?%~E_ӯ7-:GCX?՟KZG/oYտO[C41 jVZڨ:FhCci-IKҴ -KH+ʴ JIkڴKmHƴ MBdQlr(BQQ6i ڒiJPR eimKi;Di{BSi@iͤY#ͦhgCЮN{ОnSK}OڋRDeBUQ|Z@ iC~?@At0Bat8AGQt4Cqt<@'It2Bit:AgYt6Cyt>]@Et1]Bet9]AWUt5]Cut=@7Mt3Bmt;Aw]t7C}t?=@C0=Bc8=AOS4=Cs<@/K2Bk:Ao[6C{>}@G1}Bg9}A_W5}Cw=@?ҿ~_+F'E?X31n%۹;y1<//+̫kơxޔ8f#y3ޜ-y+ޚ'9ip'/| !|(Ƈ|$G1|, |"')|*Ƨ|&g9|.|!_%|)_Ɨ|%_W5|-_ |#7-|+Ʒ|'w=|/ ?#(?Ə$?O3,? "/+*Ư&o;.!')Ɵ%_7-#g˿o;_7#JiVYBڤ]:SFh#ce,)KҲ,+򲂬(+ʲ*fu!kQuM=V#5quz@+kڲ+l(ƲMKBbIXlq$"QI\6e ReIHRRdձ2ALɲL2Mv2Cf,QfN̑]dWMv=dOIՙluAzUWP'H:U&Rde@JRA[*Re̗P>'r$!r&r%G1r' r$')r&r%g9r'r\$%r\&r\%W5r\' r$7-r&r%w=r'<$#<&<%O3<' $/+&%o;'|$'|&|%_7|'K-gE+o!_cц 1ƴVi3tQfcƚqfIY,cUwfYɬlV1f Yˬm1fll61ͦ˄e6ln0[f0I2i1Y3lk&$3loAfv0 32;f'cv1fən7=55E3`Jlަbffofk3́ s9j3#̑(s9k3Ǜ̉$s9ŜjN33̙,s9ǜk3 ̅"s\j.3+̕*s\k3כ̍&sjn3;̝.sk3̃!yŸ,Ÿ,Ÿ,Ÿ,Ÿ,Ÿ,]]Ԃ6ԁFQh &Ih fM?~Zmlv!C[[[[[[c3aMFʰ? ~0amm66m|||||||||||||||||||||||||Q#G?~#GF,m$KF,m$K; ~1c?~8q?~8qJv 'O?~ UN? ~|xUN? >J7%? ~)SO?~ )SO?>|h#ȇ6|h#ȇ6|h#ȇ6|h#ȇ6|h#3gπ?~ 3gπ?>k#ȿ6k#ȿ6k#ȿ6k#ȿ :ȿ :ȿ :ȿ :ȿ :ȿ :ȿ :ȿ :ȿ :ȿ :ȿ :ȿ :VeN2?|_fmZ-;ҰwԂ6ԁFQh &Ih f@C?~x!B ς} -ط`߂} -g!> < < < < ԁFQh &%-;kjGoaPsKl[R)/VUlҘ 痂Vw߆i=DZZg0.>; ~|P.u{ rEw[{5brꎪB>W,k퍓Xnv?[aƠ BoƷP[-jt 5BnFP[-jt 5BnFP[-jt 5BnFP[-jt 5BnFP[-jtO? ~0a? ~0aǦ;;;vT;x<jOqwwwww?~#G?~Q؏~;l6uM`SwC6uvAM6R8ԝX4-bo81нR Ƌj5֞=6EۢmA#8b=m-^&-/$}'pho!MjB>hZ D A-[DCf /ixi\4̦mҼfiĐUI㪤@43 f@̀]ɀ$ 9HB7Y~,gYPgY:Pk.zimpRK;%6i1Ao)IX6nλ!=@1P"ŹCU!ti껐 !C*lK%z8:2[i'xww,m+'/>xxxwFZڻWH_ͶrW< ~5L,`0`4`T~o4o4xjy ?/O~g7FF3`ß` Dhq䋹F]7>7Po MjB_pFwWEۨa뗈~l?׭ O#SF*niĂÍ<7 4 7@ķF  No7 #o-~|K[@y$xOJ}ŧF{s]Ƴ6v7kW` ^GOXK78! Nh^4N&;N<[Xbŏ*z BmaW]j(` ¸q%` 0?&WOa^i}{ |p!n,F =2} b0X9|Xo- bO7mЭ ߝ^xȕzoFޅ:+/j}{m`X^k҉\,ohޖ?|_wdklm oI'`*?qN8JJo,,WpJ|ӋK9tc)mlS~a'?xcp"(b##c_Ɲ  ؜03h99ٙ9 FNV^fnv~&.6>FNV^fnv~&.6>FNV^fnv~&.6>FNV^fnv~    & . 6 > F N V ^ f n v ~                     & . 6 > F N V ^ f n v ~                     & . 6 > F N V ^ f n v ~                     & . 6 > F N V ^ f n v ߖUUU$H@ @@<<8|||8 v|T(~ի~Zl(8(P 8lTl*"\zf(@@$$$(((((|||DH$JD0Hh0JL60    l88l|0 <00 @@B< ~~  8D8D@<$BB~BB|BB|BB|F:@@\bBB|<@@@<:FBB><@@\bBBB0< $@@DX`XD08쒒\bBBBBB>\" >@<|< BBBF:DD((DD((DBBF:<| |   2LUUUU"x x" 88V (T8T(D(|| $8X400  80@@08 (T|T( ljl||l @D8F:<>F:<>F:(<>F:$<>F:<>F:~ n<@@@<