diff --git a/Allure.cabal b/Allure.cabal --- a/Allure.cabal +++ b/Allure.cabal @@ -1,101 +1,65 @@ cabal-version: >= 1.10 name: Allure -version: 0.4.2 -license: BSD3 +version: 0.4.3 +license: OtherLicense license-file: LICENSE -tested-with: GHC == 7.2.1, GHC == 7.3 -data-files: LICENSE, CREDITS, PLAYING.md, - README.md, src/config.default, src/config.bot, scores +tested-with: GHC == 7.2.2, GHC == 7.4 +data-files: LICENSE, CREDITS, PLAYING.md, README.md, + config.default, config.bot, scores author: Andres Loeh, Mikolaj Konarski and others maintainer: Mikolaj Konarski -description: This is an alpha pre-release of Allure of the Stars, +description: This is an alpha release of Allure of the Stars, a near-future Sci-Fi roguelike and tactical squad game. + The game is barely fun at this stage and not yet + really Sci-Fi. See the wiki for design notes and contribute. + . Long term goals are high replayability and auto-balancing through procedural content generation and persistent content modification based on player behaviour. . - The game is based (for the time being, as a fork) - on the LambdaHack roguelike game engine available - at . -synopsis: Near-future roguelike game in early development + The game is written using the LambdaHack roguelike game engine + available at . +synopsis: Near-future roguelike game in very early and active development homepage: http://github.com/Mikolaj/Allure bug-reports: http://github.com/Mikolaj/Allure/issues category: Game build-type: Simple -flag curses - description: enable curses support - default: False - -flag vty - description: enable vty support - default: False - -flag std - description: enable stdin/stdout support - default: False - -executable Allure - main-is: Main.hs - hs-source-dirs: src - other-modules: Action, Actions, ActorAdd, Actor, ActorState, Area, AreaRnd, - Cave, Color, Command, Config, ConfigDefault, - Content.Content, Content.ActorKind, Content.CaveKind, - Content.ItemKind, Content.TileKind, - Dir, Display, Dungeon, DungeonState, - Effect, EffectAction, Feature, Flavour, - FOV, FOV.Common, FOV.Digital, FOV.Permissive, FOV.Shadow, - Frequency, Geometry, Grammar, - HighScores, Item, ItemAction, - Keys, Keybindings, Kind, Level, LevelState, Loc - Message, Perception, Random, - Save, State, Strategy, StrategyState, Tile, Turn, - Utils.Assert, Utils.File, Utils.Multiline, - Version, WorldLoc - build-depends: ConfigFile >= 1.1.1 && < 2, - array >= 0.3.0.3 && < 1, base >= 4 && < 5, - binary >= 0.5.0.2 && < 1, bytestring >= 0.9.2 && < 1, - containers >= 0.4.1 && < 1, directory >= 1.1.0.1 && < 2, - filepath >= 1.2.0.1 && < 2, mtl >= 2.0.1 && < 3, - old-time >= 1.0.0.7 && < 2, random >= 1.0.1 && < 2, - template-haskell >= 2.6 && < 3, transformers >= 0.2.2 && < 1, - zlib >= 0.5.3.1 && < 1 - - default-language: Haskell2010 - default-extensions: BangPatterns, RecordWildCards, NamedFieldPuns - other-extensions: CPP, QuasiQuotes, MultiParamTypeClasses, RankNTypes - ghc-options: -Wall -fwarn-orphans -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -fwarn-monomorphism-restriction -fwarn-unrecognised-pragmas - ghc-options: -fno-warn-auto-orphans -fno-warn-implicit-prelude -fno-warn-unused-do-bind - ghc-options: -fno-ignore-asserts -funbox-strict-fields - - if flag(curses) { - other-modules: Display.Curses - build-depends: hscurses >= 1.4.1 && < 2 - cpp-options: -DCURSES - extra-libraries: curses - } else { if flag(vty) { - other-modules: Display.Vty - build-depends: vty >= 4.7.0.6 - cpp-options: -DVTY - } else { if flag(std) { - cpp-options: -DSTD - } else { - other-modules: Display.Gtk - build-depends: gtk >= 0.12.1 && < 0.13 - ghc-options: -threaded - } } } - -executable BotAllure - main-is: Bot.hs - hs-source-dirs: src - build-depends: base >= 4 && < 5, random >= 1.0.1 && < 2 - default-language: Haskell2010 - default-extensions: BangPatterns, RecordWildCards, NamedFieldPuns - other-extensions: CPP, QuasiQuotes, MultiParamTypeClasses, RankNTypes - ghc-options: -Wall -fwarn-orphans -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -fwarn-monomorphism-restriction -fwarn-unrecognised-pragmas - ghc-options: -fno-warn-auto-orphans -fno-warn-implicit-prelude -fno-warn-unused-do-bind - ghc-options: -fno-ignore-asserts -funbox-strict-fields - source-repository head type: git location: git://github.com/Mikolaj/Allure.git + +executable Allure + main-is: Main.hs + other-modules: Content.ActorKind, + Content.CaveKind, + Content.ItemKind, + Content.PlaceKind, + Content.RuleKind, + Content.TileKind, + Multiline, + ConfigDefault + hs-source-dirs: src + other-modules: Paths_Allure + build-depends: LambdaHack >= 0.2.0 && < 0.2.1, + template-haskell >= 2.6 && < 3, + ConfigFile >= 1.1.1 && < 2, + array >= 0.3.0.3 && < 1, + base >= 4 && < 5, + binary >= 0.5.0.2 && < 1, + bytestring >= 0.9.2 && < 1, + containers >= 0.4.1 && < 1, + directory >= 1.1.0.1 && < 2, + filepath >= 1.2.0.1 && < 2, + mtl >= 2.0.1 && < 3, + old-time >= 1.0.0.7 && < 2, + random >= 1.0.1 && < 2, + zlib >= 0.5.3.1 && < 1 + default-language: Haskell2010 + default-extensions: MonoLocalBinds, + BangPatterns, RecordWildCards, NamedFieldPuns + other-extensions: CPP, QuasiQuotes + ghc-options: -Wall -fwarn-orphans -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -fwarn-monomorphism-restriction -fwarn-unrecognised-pragmas + ghc-options: -fno-warn-auto-orphans -fno-warn-implicit-prelude -fno-warn-unused-do-bind + ghc-options: -fno-ignore-asserts -funbox-strict-fields + ghc-options: -threaded diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,28 +1,661 @@ -Copyright (c) 2008--2011 Andres Loeh -Copyright (c) 2010--2011 Mikolaj Konarski + GNU AFFERO GENERAL PUBLIC LICENSE + Version 3, 19 November 2007 -All rights reserved. + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions -are met: -1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. -2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. -3. Neither the name of the author nor the names of his contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. + Preamble -THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE -IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE -ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS -OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) -HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT -LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY -OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF -SUCH DAMAGE. + The GNU Affero General Public License is a free, copyleft license for +software and other kinds of works, specifically designed to ensure +cooperation with the community in the case of network server software. + + The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +our General Public Licenses are intended to guarantee your freedom to +share and change all versions of a program--to make sure it remains free +software for all its users. + + 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 +them 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. + + Developers that use our General Public Licenses protect your rights +with two steps: (1) assert copyright on the software, and (2) offer +you this License which gives you legal permission to copy, distribute +and/or modify the software. + + A secondary benefit of defending all users' freedom is that +improvements made in alternate versions of the program, if they +receive widespread use, become available for other developers to +incorporate. Many developers of free software are heartened and +encouraged by the resulting cooperation. However, in the case of +software used on network servers, this result may fail to come about. +The GNU General Public License permits making a modified version and +letting the public access it on a server without ever releasing its +source code to the public. + + The GNU Affero General Public License is designed specifically to +ensure that, in such cases, the modified source code becomes available +to the community. It requires the operator of a network server to +provide the source code of the modified version running there to the +users of that server. Therefore, public use of a modified version, on +a publicly accessible server, gives the public access to the source +code of the modified version. + + An older license, called the Affero General Public License and +published by Affero, was designed to accomplish similar goals. This is +a different license, not a version of the Affero GPL, but Affero has +released a new version of the Affero GPL which permits relicensing under +this license. + + The precise terms and conditions for copying, distribution and +modification follow. + + TERMS AND CONDITIONS + + 0. Definitions. + + "This License" refers to version 3 of the GNU Affero General Public License. + + "Copyright" also means copyright-like laws that apply to other kinds of +works, such as semiconductor masks. + + "The Program" refers to any copyrightable work licensed under this +License. Each licensee is addressed as "you". "Licensees" and +"recipients" may be individuals or organizations. + + To "modify" a work means to copy from or adapt all or part of the work +in a fashion requiring copyright permission, other than the making of an +exact copy. The resulting work is called a "modified version" of the +earlier work or a work "based on" the earlier work. + + A "covered work" means either the unmodified Program or a work based +on the Program. + + To "propagate" a work means to do anything with it that, without +permission, would make you directly or secondarily liable for +infringement under applicable copyright law, except executing it on a +computer or modifying a private copy. Propagation includes copying, +distribution (with or without modification), making available to the +public, and in some countries other activities as well. + + To "convey" a work means any kind of propagation that enables other +parties to make or receive copies. Mere interaction with a user through +a computer network, with no transfer of a copy, is not conveying. + + An interactive user interface displays "Appropriate Legal Notices" +to the extent that it includes a convenient and prominently visible +feature that (1) displays an appropriate copyright notice, and (2) +tells the user that there is no warranty for the work (except to the +extent that warranties are provided), that licensees may convey the +work under this License, and how to view a copy of this License. If +the interface presents a list of user commands or options, such as a +menu, a prominent item in the list meets this criterion. + + 1. Source Code. + + The "source code" for a work means the preferred form of the work +for making modifications to it. "Object code" means any non-source +form of a work. + + A "Standard Interface" means an interface that either is an official +standard defined by a recognized standards body, or, in the case of +interfaces specified for a particular programming language, one that +is widely used among developers working in that language. + + The "System Libraries" of an executable work include anything, other +than the work as a whole, that (a) is included in the normal form of +packaging a Major Component, but which is not part of that Major +Component, and (b) serves only to enable use of the work with that +Major Component, or to implement a Standard Interface for which an +implementation is available to the public in source code form. A +"Major Component", in this context, means a major essential component +(kernel, window system, and so on) of the specific operating system +(if any) on which the executable work runs, or a compiler used to +produce the work, or an object code interpreter used to run it. + + The "Corresponding Source" for a work in object code form means all +the source code needed to generate, install, and (for an executable +work) run the object code and to modify the work, including scripts to +control those activities. However, it does not include the work's +System Libraries, or general-purpose tools or generally available free +programs which are used unmodified in performing those activities but +which are not part of the work. For example, Corresponding Source +includes interface definition files associated with source files for +the work, and the source code for shared libraries and dynamically +linked subprograms that the work is specifically designed to require, +such as by intimate data communication or control flow between those +subprograms and other parts of the work. + + The Corresponding Source need not include anything that users +can regenerate automatically from other parts of the Corresponding +Source. + + The Corresponding Source for a work in source code form is that +same work. + + 2. Basic Permissions. + + All rights granted under this License are granted for the term of +copyright on the Program, and are irrevocable provided the stated +conditions are met. This License explicitly affirms your unlimited +permission to run the unmodified Program. The output from running a +covered work is covered by this License only if the output, given its +content, constitutes a covered work. This License acknowledges your +rights of fair use or other equivalent, as provided by copyright law. + + You may make, run and propagate covered works that you do not +convey, without conditions so long as your license otherwise remains +in force. You may convey covered works to others for the sole purpose +of having them make modifications exclusively for you, or provide you +with facilities for running those works, provided that you comply with +the terms of this License in conveying all material for which you do +not control copyright. Those thus making or running the covered works +for you must do so exclusively on your behalf, under your direction +and control, on terms that prohibit them from making any copies of +your copyrighted material outside their relationship with you. + + Conveying under any other circumstances is permitted solely under +the conditions stated below. Sublicensing is not allowed; section 10 +makes it unnecessary. + + 3. Protecting Users' Legal Rights From Anti-Circumvention Law. + + No covered work shall be deemed part of an effective technological +measure under any applicable law fulfilling obligations under article +11 of the WIPO copyright treaty adopted on 20 December 1996, or +similar laws prohibiting or restricting circumvention of such +measures. + + When you convey a covered work, you waive any legal power to forbid +circumvention of technological measures to the extent such circumvention +is effected by exercising rights under this License with respect to +the covered work, and you disclaim any intention to limit operation or +modification of the work as a means of enforcing, against the work's +users, your or third parties' legal rights to forbid circumvention of +technological measures. + + 4. Conveying Verbatim Copies. + + You may convey 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; +keep intact all notices stating that this License and any +non-permissive terms added in accord with section 7 apply to the code; +keep intact all notices of the absence of any warranty; and give all +recipients a copy of this License along with the Program. + + You may charge any price or no price for each copy that you convey, +and you may offer support or warranty protection for a fee. + + 5. Conveying Modified Source Versions. + + You may convey a work based on the Program, or the modifications to +produce it from the Program, in the form of source code under the +terms of section 4, provided that you also meet all of these conditions: + + a) The work must carry prominent notices stating that you modified + it, and giving a relevant date. + + b) The work must carry prominent notices stating that it is + released under this License and any conditions added under section + 7. This requirement modifies the requirement in section 4 to + "keep intact all notices". + + c) You must license the entire work, as a whole, under this + License to anyone who comes into possession of a copy. This + License will therefore apply, along with any applicable section 7 + additional terms, to the whole of the work, and all its parts, + regardless of how they are packaged. This License gives no + permission to license the work in any other way, but it does not + invalidate such permission if you have separately received it. + + d) If the work has interactive user interfaces, each must display + Appropriate Legal Notices; however, if the Program has interactive + interfaces that do not display Appropriate Legal Notices, your + work need not make them do so. + + A compilation of a covered work with other separate and independent +works, which are not by their nature extensions of the covered work, +and which are not combined with it such as to form a larger program, +in or on a volume of a storage or distribution medium, is called an +"aggregate" if the compilation and its resulting copyright are not +used to limit the access or legal rights of the compilation's users +beyond what the individual works permit. Inclusion of a covered work +in an aggregate does not cause this License to apply to the other +parts of the aggregate. + + 6. Conveying Non-Source Forms. + + You may convey a covered work in object code form under the terms +of sections 4 and 5, provided that you also convey the +machine-readable Corresponding Source under the terms of this License, +in one of these ways: + + a) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by the + Corresponding Source fixed on a durable physical medium + customarily used for software interchange. + + b) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by a + written offer, valid for at least three years and valid for as + long as you offer spare parts or customer support for that product + model, to give anyone who possesses the object code either (1) a + copy of the Corresponding Source for all the software in the + product that is covered by this License, on a durable physical + medium customarily used for software interchange, for a price no + more than your reasonable cost of physically performing this + conveying of source, or (2) access to copy the + Corresponding Source from a network server at no charge. + + c) Convey individual copies of the object code with a copy of the + written offer to provide the Corresponding Source. This + alternative is allowed only occasionally and noncommercially, and + only if you received the object code with such an offer, in accord + with subsection 6b. + + d) Convey the object code by offering access from a designated + place (gratis or for a charge), and offer equivalent access to the + Corresponding Source in the same way through the same place at no + further charge. You need not require recipients to copy the + Corresponding Source along with the object code. If the place to + copy the object code is a network server, the Corresponding Source + may be on a different server (operated by you or a third party) + that supports equivalent copying facilities, provided you maintain + clear directions next to the object code saying where to find the + Corresponding Source. Regardless of what server hosts the + Corresponding Source, you remain obligated to ensure that it is + available for as long as needed to satisfy these requirements. + + e) Convey the object code using peer-to-peer transmission, provided + you inform other peers where the object code and Corresponding + Source of the work are being offered to the general public at no + charge under subsection 6d. + + A separable portion of the object code, whose source code is excluded +from the Corresponding Source as a System Library, need not be +included in conveying the object code work. + + A "User Product" is either (1) a "consumer product", which means any +tangible personal property which is normally used for personal, family, +or household purposes, or (2) anything designed or sold for incorporation +into a dwelling. In determining whether a product is a consumer product, +doubtful cases shall be resolved in favor of coverage. For a particular +product received by a particular user, "normally used" refers to a +typical or common use of that class of product, regardless of the status +of the particular user or of the way in which the particular user +actually uses, or expects or is expected to use, the product. A product +is a consumer product regardless of whether the product has substantial +commercial, industrial or non-consumer uses, unless such uses represent +the only significant mode of use of the product. + + "Installation Information" for a User Product means any methods, +procedures, authorization keys, or other information required to install +and execute modified versions of a covered work in that User Product from +a modified version of its Corresponding Source. The information must +suffice to ensure that the continued functioning of the modified object +code is in no case prevented or interfered with solely because +modification has been made. + + If you convey an object code work under this section in, or with, or +specifically for use in, a User Product, and the conveying occurs as +part of a transaction in which the right of possession and use of the +User Product is transferred to the recipient in perpetuity or for a +fixed term (regardless of how the transaction is characterized), the +Corresponding Source conveyed under this section must be accompanied +by the Installation Information. But this requirement does not apply +if neither you nor any third party retains the ability to install +modified object code on the User Product (for example, the work has +been installed in ROM). + + The requirement to provide Installation Information does not include a +requirement to continue to provide support service, warranty, or updates +for a work that has been modified or installed by the recipient, or for +the User Product in which it has been modified or installed. Access to a +network may be denied when the modification itself materially and +adversely affects the operation of the network or violates the rules and +protocols for communication across the network. + + Corresponding Source conveyed, and Installation Information provided, +in accord with this section must be in a format that is publicly +documented (and with an implementation available to the public in +source code form), and must require no special password or key for +unpacking, reading or copying. + + 7. Additional Terms. + + "Additional permissions" are terms that supplement the terms of this +License by making exceptions from one or more of its conditions. +Additional permissions that are applicable to the entire Program shall +be treated as though they were included in this License, to the extent +that they are valid under applicable law. If additional permissions +apply only to part of the Program, that part may be used separately +under those permissions, but the entire Program remains governed by +this License without regard to the additional permissions. + + When you convey a copy of a covered work, you may at your option +remove any additional permissions from that copy, or from any part of +it. (Additional permissions may be written to require their own +removal in certain cases when you modify the work.) You may place +additional permissions on material, added by you to a covered work, +for which you have or can give appropriate copyright permission. + + Notwithstanding any other provision of this License, for material you +add to a covered work, you may (if authorized by the copyright holders of +that material) supplement the terms of this License with terms: + + a) Disclaiming warranty or limiting liability differently from the + terms of sections 15 and 16 of this License; or + + b) Requiring preservation of specified reasonable legal notices or + author attributions in that material or in the Appropriate Legal + Notices displayed by works containing it; or + + c) Prohibiting misrepresentation of the origin of that material, or + requiring that modified versions of such material be marked in + reasonable ways as different from the original version; or + + d) Limiting the use for publicity purposes of names of licensors or + authors of the material; or + + e) Declining to grant rights under trademark law for use of some + trade names, trademarks, or service marks; or + + f) Requiring indemnification of licensors and authors of that + material by anyone who conveys the material (or modified versions of + it) with contractual assumptions of liability to the recipient, for + any liability that these contractual assumptions directly impose on + those licensors and authors. + + All other non-permissive additional terms are considered "further +restrictions" within the meaning of section 10. If the Program as you +received it, or any part of it, contains a notice stating that it is +governed by this License along with a term that is a further +restriction, you may remove that term. If a license document contains +a further restriction but permits relicensing or conveying under this +License, you may add to a covered work material governed by the terms +of that license document, provided that the further restriction does +not survive such relicensing or conveying. + + If you add terms to a covered work in accord with this section, you +must place, in the relevant source files, a statement of the +additional terms that apply to those files, or a notice indicating +where to find the applicable terms. + + Additional terms, permissive or non-permissive, may be stated in the +form of a separately written license, or stated as exceptions; +the above requirements apply either way. + + 8. Termination. + + You may not propagate or modify a covered work except as expressly +provided under this License. Any attempt otherwise to propagate or +modify it is void, and will automatically terminate your rights under +this License (including any patent licenses granted under the third +paragraph of section 11). + + However, if you cease all violation of this License, then your +license from a particular copyright holder is reinstated (a) +provisionally, unless and until the copyright holder explicitly and +finally terminates your license, and (b) permanently, if the copyright +holder fails to notify you of the violation by some reasonable means +prior to 60 days after the cessation. + + Moreover, your license from a particular copyright holder is +reinstated permanently if the copyright holder notifies you of the +violation by some reasonable means, this is the first time you have +received notice of violation of this License (for any work) from that +copyright holder, and you cure the violation prior to 30 days after +your receipt of the notice. + + Termination of your rights under this section does not terminate the +licenses of parties who have received copies or rights from you under +this License. If your rights have been terminated and not permanently +reinstated, you do not qualify to receive new licenses for the same +material under section 10. + + 9. Acceptance Not Required for Having Copies. + + You are not required to accept this License in order to receive or +run a copy of the Program. Ancillary propagation of a covered work +occurring solely as a consequence of using peer-to-peer transmission +to receive a copy likewise does not require acceptance. However, +nothing other than this License grants you permission to propagate or +modify any covered work. These actions infringe copyright if you do +not accept this License. Therefore, by modifying or propagating a +covered work, you indicate your acceptance of this License to do so. + + 10. Automatic Licensing of Downstream Recipients. + + Each time you convey a covered work, the recipient automatically +receives a license from the original licensors, to run, modify and +propagate that work, subject to this License. You are not responsible +for enforcing compliance by third parties with this License. + + An "entity transaction" is a transaction transferring control of an +organization, or substantially all assets of one, or subdividing an +organization, or merging organizations. If propagation of a covered +work results from an entity transaction, each party to that +transaction who receives a copy of the work also receives whatever +licenses to the work the party's predecessor in interest had or could +give under the previous paragraph, plus a right to possession of the +Corresponding Source of the work from the predecessor in interest, if +the predecessor has it or can get it with reasonable efforts. + + You may not impose any further restrictions on the exercise of the +rights granted or affirmed under this License. For example, you may +not impose a license fee, royalty, or other charge for exercise of +rights granted under this License, and you may not initiate litigation +(including a cross-claim or counterclaim in a lawsuit) alleging that +any patent claim is infringed by making, using, selling, offering for +sale, or importing the Program or any portion of it. + + 11. Patents. + + A "contributor" is a copyright holder who authorizes use under this +License of the Program or a work on which the Program is based. The +work thus licensed is called the contributor's "contributor version". + + A contributor's "essential patent claims" are all patent claims +owned or controlled by the contributor, whether already acquired or +hereafter acquired, that would be infringed by some manner, permitted +by this License, of making, using, or selling its contributor version, +but do not include claims that would be infringed only as a +consequence of further modification of the contributor version. For +purposes of this definition, "control" includes the right to grant +patent sublicenses in a manner consistent with the requirements of +this License. + + Each contributor grants you a non-exclusive, worldwide, royalty-free +patent license under the contributor's essential patent claims, to +make, use, sell, offer for sale, import and otherwise run, modify and +propagate the contents of its contributor version. + + In the following three paragraphs, a "patent license" is any express +agreement or commitment, however denominated, not to enforce a patent +(such as an express permission to practice a patent or covenant not to +sue for patent infringement). To "grant" such a patent license to a +party means to make such an agreement or commitment not to enforce a +patent against the party. + + If you convey a covered work, knowingly relying on a patent license, +and the Corresponding Source of the work is not available for anyone +to copy, free of charge and under the terms of this License, through a +publicly available network server or other readily accessible means, +then you must either (1) cause the Corresponding Source to be so +available, or (2) arrange to deprive yourself of the benefit of the +patent license for this particular work, or (3) arrange, in a manner +consistent with the requirements of this License, to extend the patent +license to downstream recipients. "Knowingly relying" means you have +actual knowledge that, but for the patent license, your conveying the +covered work in a country, or your recipient's use of the covered work +in a country, would infringe one or more identifiable patents in that +country that you have reason to believe are valid. + + If, pursuant to or in connection with a single transaction or +arrangement, you convey, or propagate by procuring conveyance of, a +covered work, and grant a patent license to some of the parties +receiving the covered work authorizing them to use, propagate, modify +or convey a specific copy of the covered work, then the patent license +you grant is automatically extended to all recipients of the covered +work and works based on it. + + A patent license is "discriminatory" if it does not include within +the scope of its coverage, prohibits the exercise of, or is +conditioned on the non-exercise of one or more of the rights that are +specifically granted under this License. You may not convey a covered +work if you are a party to an arrangement with a third party that is +in the business of distributing software, under which you make payment +to the third party based on the extent of your activity of conveying +the work, and under which the third party grants, to any of the +parties who would receive the covered work from you, a discriminatory +patent license (a) in connection with copies of the covered work +conveyed by you (or copies made from those copies), or (b) primarily +for and in connection with specific products or compilations that +contain the covered work, unless you entered into that arrangement, +or that patent license was granted, prior to 28 March 2007. + + Nothing in this License shall be construed as excluding or limiting +any implied license or other defenses to infringement that may +otherwise be available to you under applicable patent law. + + 12. No Surrender of Others' Freedom. + + If 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 convey a +covered work so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you may +not convey it at all. For example, if you agree to terms that obligate you +to collect a royalty for further conveying from those to whom you convey +the Program, the only way you could satisfy both those terms and this +License would be to refrain entirely from conveying the Program. + + 13. Remote Network Interaction; Use with the GNU General Public License. + + Notwithstanding any other provision of this License, if you modify the +Program, your modified version must prominently offer all users +interacting with it remotely through a computer network (if your version +supports such interaction) an opportunity to receive the Corresponding +Source of your version by providing access to the Corresponding Source +from a network server at no charge, through some standard or customary +means of facilitating copying of software. This Corresponding Source +shall include the Corresponding Source for any work covered by version 3 +of the GNU General Public License that is incorporated pursuant to the +following paragraph. + + Notwithstanding any other provision of this License, you have +permission to link or combine any covered work with a work licensed +under version 3 of the GNU General Public License into a single +combined work, and to convey the resulting work. The terms of this +License will continue to apply to the part which is the covered work, +but the work with which it is combined will remain governed by version +3 of the GNU General Public License. + + 14. Revised Versions of this License. + + The Free Software Foundation may publish revised and/or new versions of +the GNU Affero 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 that a certain numbered version of the GNU Affero General +Public License "or any later version" applies to it, you have the +option of following the terms and conditions either of that numbered +version or of any later version published by the Free Software +Foundation. If the Program does not specify a version number of the +GNU Affero General Public License, you may choose any version ever published +by the Free Software Foundation. + + If the Program specifies that a proxy can decide which future +versions of the GNU Affero General Public License can be used, that proxy's +public statement of acceptance of a version permanently authorizes you +to choose that version for the Program. + + Later license versions may give you additional or different +permissions. However, no additional obligations are imposed on any +author or copyright holder as a result of your choosing to follow a +later version. + + 15. Disclaimer of Warranty. + + 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. + + 16. Limitation of Liability. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS +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. + + 17. Interpretation of Sections 15 and 16. + + If the disclaimer of warranty and limitation of liability provided +above cannot be given local legal effect according to their terms, +reviewing courts shall apply local law that most closely approximates +an absolute waiver of all civil liability in connection with the +Program, unless a warranty or assumption of liability accompanies a +copy of the Program in return for a fee. + + 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 +state 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 Affero General Public License as published by + the Free Software Foundation, either version 3 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 Affero General Public License for more details. + + You should have received a copy of the GNU Affero General Public License + along with this program. If not, see . + +Also add information on how to contact you by electronic and paper mail. + + If your software can interact with users remotely through a computer +network, you should also make sure that it provides a way for users to +get its source. For example, if your program is a web application, its +interface could display a "Source" link that leads users to an archive +of the code. There are many ways you could offer source, and different +solutions will be better for different programs; see section 13 for the +specific requirements. + + You should also get your employer (if you work as a programmer) or school, +if any, to sign a "copyright disclaimer" for the program, if necessary. +For more information on this, and how to apply and follow the GNU AGPL, see +. diff --git a/PLAYING.md b/PLAYING.md --- a/PLAYING.md +++ b/PLAYING.md @@ -1,31 +1,31 @@ Playing Allure of the Stars =========================== -Playing Allure of the Stars involves walking around the dungeon -(err, a Solar System space-ship that incidentally closely resembles -a fantasy dungeon, in this pre-release version of the game), -alone or in a party of fearless adventurers, jumping between levels, -bumping into monsters, doors and walls, gathering magical treasure -and making creative use of it. The bloodthirsty monsters do the same, -intelligence allowing, while tirelessly chasing the noble heroes -by smell and night-sight. +Playing Allure of the Stars involves walking around an abandoned +Solar System space-ship, alone or in a party of trusted crew-members, +setting up ambushes, hiding in shadow, covering tracks, +breaking through to deeper spaceship decks, bumping into +hostile intruders, doors and walls, gathering technical resources +and making creative use of them. The bloodthirsty alien monsters +and their horrible minions do the same, intelligence allowing, +while tirelessly chasing the stranded heroes by smell and sight. Once the few basic command keys and on-screen symbols are learned, mastery and enjoyment of the game is the matter of tactical skill and literary imagination. To be honest, a lot of imagination is required -right now, but the game is already playable and winnable. +at this stage, but the game is already playable and winnable. Contributions welcome. -Dungeon +Terrain ------- -The goal of the hero is to explore the dungeon, battle the horrors within, -gather as much gold and gems as possible, and escape to tell the tale. -The dungeon consists of 10 levels and each level consists of 80 by 21 tiles. -The basic tiles are as follows. +The goal of the hero is to explore an old, once luxurious space liner, +battle the horrors within, gather as much gold coins and precious gems +as possible, and escape to tell the tale. The spaceship consists +of many levels covered with varying terrain of the following basic kinds: - dungeon terrain type on-screen symbol + terrain type on-screen symbol floor . wall # stairs up < @@ -35,12 +35,12 @@ The game world is persistent, i.e., every time the player visits a level during a single game, the level layout is the same. Some items -aid in dungeon exploration, e.g., a ring of searching improves the speed -of finding hidden doors by heroes and monsters. The higher the magical -bonus displayed for this and other dungeon items, the more effective it is. +aid in exploration, e.g., a ring of searching improves the speed +of finding hidden doors by heroes and monsters. The higher the ability +bonus displayed for this and other items, the more effective it is. Only the best item carried in a hero's or monster's inventory counts. You can throw the rest away, but beware that your adversaries may pick it up -and use it against you. +and use it against your party. Keys @@ -60,43 +60,58 @@ (Note that If you are using the curses or vty frontends, numerical keypad may not work correctly depending on the versions of curses, terminfo and terminal emulators. Vi keys should work regardless.) +Melee, searching for secret doors and opening closed doors can be done +by bumping into a monster, a wall and a door, respectively. -Below are the basic default keys form common commands. +Below are the default keys for major commands. The last four commands +are specialized versions of 'a' and 'p', offering narrower default item choice. +The commands that take player time are marked with a *. key command - < ascend a level - > descend a level + < ascend a level* + > descend a level* ? display help Q quit without saving X save and exit the game - c close a door - d drop an object - g get an object + a apply a consumable* + c close a door* + d drop an object* + g get an object* i display inventory - q quaff a potion - r read a scroll - a aim a wand - t throw a weapon + p project a projectile* + q quaff a drink* + r read a comm* + t throw a missile* + z zap a mechanism* -Searching for secret doors and opening closed doors have no keys assigned. -Instead, bump into a wall to search and bump into a door to open. +To make a ranged attack, you need to set your target first, using +targeting mode. Note that the target, for the few commands that require any, +is indicated by the targeting cursor. The origin of a command +--- the hero that performs it --- is unaffected by targeting. For example, +not the targeted door, but one adjacent to the selected hero is closed by him. -To make a distance attack, you need to set your target first. -The targeting commands are listed below, together with all the other -less used commands. +To avoid confusion, commands that take time are blocked when targeting +at a remote level (when the cursor is on a different level +than the selected hero). The targeting commands and all the less used +commands are listed below. None of them takes hero time. key command ESC cancel action RET accept choice + SPACE clear messages TAB cycle among heroes on level - 0--9 select a hero anywhere in the dungeon (gtk only) * target monster / target location D dump current configuration P display previous messages V display game version + [ target next shallower level + ] target next deeper level + { target 10 levels shallower + } target 10 levels deeper + 0--9 select a hero anywhere in the spaceship (gtk only) -There are also some debug and cheat keys. Use at your peril! +There are also some debug and cheat keys. Use at your own peril! key command O toggle "omniscience" @@ -107,11 +122,11 @@ Monsters -------- -The hero is not alone in the dungeon. Monsters roam the dark caves -and crawl from damp holes day and night. While heroes pay attention +The hero is not alone in the spaceship. Monsters roam the dark halls +and crawl from damp air-ducts day and night. While heroes pay attention to all other party members and take moves sequentially, one after another, monsters don't care about each other and all move at once, -sometimes brutally colliding by mistake. +sometimes brutally colliding by accident. When the hero bumps into a monster or a monster attacks the hero, melee combat occurs. The best weapon carried by each opponent @@ -124,23 +139,23 @@ or aid escape. Throwing weapons at targets wounds them, consuming the weapon in the process. -You can target a monster with the '*' key from the top row or kepad. -You may throw any object in your possession -(press '*' for a non-standard choice) or on the floor (press '-'), -though only objects of a few kinds inflict any damage. -Whenever a monster or a hero hit points reach zero, the combatant dies. +Target a monster with the '*' key from the top keyboard row or from keypad. +You may throw any object in your possession (press '?' to choose +an object and press it again for a non-standard choice) or on the floor +(press '-'). Only objects of a few kinds inflict any damage. +Whenever the monster's or hero's hit points reach zero, the combatant dies. When the last hero dies, the game ends. On Winning and Dying -------------------- -You win the game if you escape the dungeon alive. Your score is -the sum of all gold you've plundered plus 100gp for each gem. -Only the loot in possession of the party members on level 1 counts -(the rest is considered MIA). +You win the game if you escape the spaceship alive. Your score is +the sum of all gold coins you've plundered plus 100 gold for each gem. +Only the loot in possession of the party members on the current level +counts (the rest of the party is considered MIA). If all heroes die, your score is halved and only the treasure carried by the last standing hero counts. You are free to start again -from the first level of the dungeon, but all your wealth and items -are gone and the dungeon and it's treasure look differently. +from a different entrance to the spaceship, but all your previous wealth +is gone and fresh, undaunted enemies bar your way. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,13 +1,12 @@ Allure of the Stars =================== -This is an alpha pre-release of Allure of the Stars, -a near-future Sci-Fi [roguelike] [1] and tactical squad game. +This is an alpha release of Allure of the Stars, +a near-future Sci-Fi [roguelike] [2] and tactical squad game. Long-term goals are high replayability and auto-balancing through procedural content generation and persistent content -modification based on player behaviour. -The game is written in [Haskell] [2] and based -on the [LambdaHack roguelike engine] [3]. +modification based on player behaviour. The game is written in [Haskell] [1] +using the [LambdaHack] [5] roguelike game engine. Compilation and installation @@ -19,52 +18,53 @@ cabal install Allure -For a more current snapshot, download the source from [github] [5] -and run Cabal from the main directory +For a newer version, install a matching LambdaHack library snapshot +from a development branch, download the game source from [github] [3] +and run 'cabal install' from the main directory. - cabal install -The best frontend (keyboard support and colours) is gtk, -but if needed, you may try one of the terminal frontends with, e.g, +Compatibility note +------------------ - cabal install -fvty +The current code was tested with GHC 7.2.2 and several pre-release versions +of GHC 7.4. A [few tweaks] [7] are needed to compile with 7.0 +and some more are needed for 6.12. -To use a crude bot for testing the game, you have to compile with -the standard input/output frontend, as follows - cabal install -fstd - -and run the bot, for example, in the following way +Further information +------------------- - BotAllure 42 20000000 | Allure > /tmp/log +For more information, visit the [wiki] [6] +and see the files PLAYING.md, CREDITS and LICENSE. -You may wish to tweak the game configuration file to let the bot play longer, -e.g., by making the dungeon much deeper, as in the supplied config.bot. +Have fun! -Savegame directory ------------------- - -If you don't want Allure of the Stars to write to the current directory, -create a personal savegame directory (on Linux it's ~/.Allure/). -and copy the scores file there. You may also want to -copy the configuration file src/config.default to -~/.Allure/config and modify it, but be careful changing -gameplay options --- they can easily unbalance or break the game. +Copyright +--------- +Copyright (c) 2008--2011 Andres Loeh, 2010--2012 Mikolaj Konarski -Further information -------------------- +Allure of the Stars is free software: you can redistribute it and/or modify +it under the terms of the GNU Affero General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. -For more information, visit the wiki at https://github.com/Mikolaj/Allure/wiki -and see the files PLAYING.md, CREDITS and LICENSE. +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 Affero General Public License for more details. -Have fun! +You should have received a copy of the GNU Affero General Public License +along with this program in file LICENSE. +If not, see . -[1]: http://roguebasin.roguelikedevelopment.org/index.php?title=Berlin_Interpretation -[2]: http://www.haskell.org/ -[3]: http://github.com/kosmikus/LambdaHack +[1]: http://www.haskell.org/ +[2]: http://roguebasin.roguelikedevelopment.org/index.php?title=Berlin_Interpretation +[3]: http://github.com/Mikolaj/Allure [4]: http://hackage.haskell.org/package/Allure -[5]: http://github.com/Mikolaj/Allure +[5]: http://github.com/kosmikus/LambdaHack +[6]: https://github.com/Mikolaj/Allure/wiki +[7]: https://github.com/Mikolaj/Allure/commit/3d0aa5bef7a0ef39e7611d4e12229224f4cead75 diff --git a/config.bot b/config.bot new file mode 100644 --- /dev/null +++ b/config.bot @@ -0,0 +1,14 @@ +; Copyright (c) 2008--2011 Andres Loeh, 2010--2012 Mikolaj Konarski +; This file is a part of the computer game Allure of the Stars +; and is released under the terms of the GNU Affero General Public License. +; For license and copyright information, see the file LICENSE. +; +; Overriding config file options to help the bot. +; DumbBot 42 20000000 | Allure > /tmp/log + +[dungeon] +depth: 100 + +[heroes] +baseHP: 999999 +extraHeroes: 1 diff --git a/config.default b/config.default new file mode 100644 --- /dev/null +++ b/config.default @@ -0,0 +1,102 @@ +; ; Copyright (c) 2008--2011 Andres Loeh, 2010--2012 Mikolaj Konarski +; ; This file is a part of the computer game Allure of the Stars +; ; and is released under the terms of the GNU Affero General Public License. +; ; For license and copyright information, see the file LICENSE. +; ; +; ; This is a commented out copy of the default config file +; ; that is embedded in the binary. +; ; The game looks for the user config file that overrides some options +; ; in the ~/.LambdaHack/config file (or similar, depending on the OS). +; ; Warning: options are case-sensitive and only ';' comments are permitted. + +; [commands] +; ; All commands are defined here, except movement, hero selection and debug. +; ; +; ; Interaction with the dungeon. +; c: TriggerDir { verb = "close", object = "door", feature = Closable } +; less: TriggerTile { verb = "ascend", object = "level", feature = Cause Ascend } +; greater: TriggerTile { verb = "descend", object = "level", feature = Cause Descend } +; bracketleft: TgtAscend 1 +; bracketright: TgtAscend (-1) +; braceleft: TgtAscend 10 +; braceright: TgtAscend (-10) +; slash: TgtFloor +; asterisk: TgtEnemy +; Tab: HeroCycle +; ; +; ; Items. +; g: Pickup +; d: Drop +; i: Inventory +; a: Apply { verb = "apply", object = "consumable", syms = "!?" } +; p: Project { verb = "project", object = "projectile", syms = "/|" } +; q: Apply { verb = "quaff", object = "drink", syms = "!" } +; r: Apply { verb = "read", object = "comm", syms = "?" } +; z: Project { verb = "zap", object = "mechanism", syms = "/" } +; t: Project { verb = "throw", object = "missile", syms = "|" } +; ; +; ; Saving or ending the game. +; X: GameSave +; Q: GameQuit +; ; +; ; Information for the player. +; P: History +; V: Version +; question: Help +; D: CfgDump +; ; +; ; General. +; KP_Begin: Wait +; Escape: Cancel +; Return: Accept +; space: Redraw + +; [dungeon] +; ; Fixed caves for the first levels, then randomly picked caves. +; LambdaCave_1: caveRogue +; LambdaCave_12: caveNoise +; depth: 12 + +; [engine] +; fovMode: digital +; ;fovMode: permissive +; ;fovMode: shadow +; fovRadius: 12 +; ;startingRandomGenerator: 42 +; ;dungeonRandomGenerator: 42 + +; [files] +; ; Paths to various game files; relative to the save file directory. +; scoresFile: scores +; saveFile: save +; diaryFile : diary + +; [heroes] +; HeroName_0: you +; HeroName_1: Haskell Alvin +; HeroName_2: Alonzo Barkley +; HeroName_3: Ernst Abraham +; HeroName_4: Samuel Saunders +; HeroName_5: Roger Robin +; baseHP: 50 +; extraHeroes: 0 +; firstDeathEnds: False + +; [macros] +; ; This sections can be empty, but has to be there. +; ; TODO: the following does not work yet: +; ;; throw a dart at the closest monster +; ;t: asterisk Return t Return +; ; TODO: in gtk it could be implemented via unGetChan, +; ; unless we prefer an explicit command queue, with flushing, etc. +; ; +; ; Handy with Vi keys: +; comma: g +; period: KP_Begin + +; [monsters] +; smellTimeout: 1000 + +; [ui] +; font: Terminus,Monospace normal normal normal normal 12 +; historyMax: 5000 diff --git a/scores b/scores Binary files a/scores and b/scores differ diff --git a/src/Action.hs b/src/Action.hs deleted file mode 100644 --- a/src/Action.hs +++ /dev/null @@ -1,253 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses, RankNTypes #-} -module Action where - -import Control.Monad -import Control.Monad.State hiding (State, state) -import qualified Data.IntMap as IM --- import System.IO (hPutStrLn, stderr) -- just for debugging - -import Perception -import Display hiding (display) -import Message -import State -import Level -import Actor -import ActorState -import Content.ActorKind -import qualified Save -import qualified Kind -import Random - -newtype Action a = Action - { runAction :: - forall r . - Session -> - IO r -> -- shutdown cont - Perceptions -> -- cached perception - (State -> Message -> a -> IO r) -> -- continuation - IO r -> -- failure/reset cont - State -> -- current state - Message -> -- current message - IO r - } - --- TODO: check if it's strict enough, if we don't keep old states for too long, --- Perhaps make state type fields strict for that, too? -instance Monad Action where - return = returnAction - (>>=) = bindAction - --- | Invokes the continuation. -returnAction :: a -> Action a -returnAction x = Action (\ _s _e _p k _a st m -> k st m x) - --- | Distributes the session and shutdown continuation, --- threads the state and message. -bindAction :: Action a -> (a -> Action b) -> Action b -bindAction m f = Action (\ s e p k a st ms -> - let next nst nm x = - runAction (f x) s e p k a nst nm - in runAction m s e p next a st ms) - -instance MonadIO Action where - liftIO x = Action (\ _s _e _p k _a st ms -> x >>= k st ms) - -instance MonadState State Action where - get = Action (\ _s _e _p k _a st ms -> k st ms st) - put nst = Action (\ _s _e _p k _a _st ms -> k nst ms ()) - --- | Exported function to run the monad. -handlerToIO :: Session -> State -> Message -> Action () -> IO () -handlerToIO sess state msg h = - runAction h - sess - (Save.rmBkp (sconfig state) >> shutdown sess) -- get out of the game - (perception_ state) -- cached perception - (\ _ _ x -> return x) -- final continuation returns result - (ioError $ userError "unhandled abort") - state - msg - --- | Invoke pseudo-random computation with the generator kept in the state. -rndToAction :: Rnd a -> Action a -rndToAction r = do - g <- gets srandom - let (a, ng) = runState r g - modify (\ state -> state {srandom = ng}) - return a - --- | Invoking a session command. -session :: (Session -> Action a) -> Action a -session f = Action (\ s e p k a st ms -> runAction (f s) s e p k a st ms) - --- | Invoking a session command. -sessionIO :: (Session -> IO a) -> Action a -sessionIO f = Action (\ s _e _p k _a st ms -> f s >>= k st ms) - --- | Display the current level with modified current message. -displayGeneric :: ColorMode -> (String -> String) -> Action Bool -displayGeneric dm f = Action (\ s _e p k _a st ms -> displayLevel dm s p st (f ms) Nothing >>= k st ms) - --- | Display the current level, with the current message and color. Most common. -display :: Action Bool -display = displayGeneric ColorFull id - --- | Display an overlay on top of the current screen. -overlay :: String -> Action Bool -overlay txt = Action (\ s _e p k _a st ms -> displayLevel ColorFull s p st ms (Just txt) >>= k st ms) - --- | Wipe out and set a new value for the current message. -messageReset :: Message -> Action () -messageReset nm = Action (\ _s _e _p k _a st _ms -> k st nm ()) - --- | Add to the current message. -messageAdd :: Message -> Action () -messageAdd nm = Action (\ _s _e _p k _a st ms -> k st (addMsg ms nm) ()) - --- | Clear the current message. -messageClear :: Action () -messageClear = Action (\ _s _e _p k _a st _ms -> k st "" ()) - --- | Get the current message. -currentMessage :: Action Message -currentMessage = Action (\ _s _e _p k _a st ms -> k st ms ms) - --- | End the game, i.e., invoke the shutdown continuation. -end :: Action () -end = Action (\ _s e _p _k _a _st _ms -> e) - --- | Reset the state and resume from the last backup point, i.e., invoke --- the failure continuation. -abort :: Action a -abort = Action (\ _s _e _p _k a _st _ms -> a) - --- | Set the current exception handler. First argument is the handler, --- second is the computation the handler scopes over. -tryWith :: Action () -> Action () -> Action () -tryWith exc h = Action (\ s e p k a st ms -> runAction h s e p k (runAction exc s e p k a st ms) st ms) - --- | Takes a handler and a computation. If the computation fails, the --- handler is invoked and then the computation is retried. -tryRepeatedlyWith :: Action () -> Action () -> Action () -tryRepeatedlyWith exc h = tryWith (exc >> tryRepeatedlyWith exc h) h - --- | Try the given computation and silently catch failure. -try :: Action () -> Action () -try = tryWith (return ()) - --- | Try the given computation until it succeeds without failure. -tryRepeatedly :: Action () -> Action () -tryRepeatedly = tryRepeatedlyWith (return ()) - --- | Print a debug message or ignore. -debug :: String -> Action () -debug _x = return () -- liftIO $ hPutStrLn stderr _x - --- | Print the given message, then abort. -abortWith :: Message -> Action a -abortWith msg = do - messageReset msg - display - abort - -neverMind :: Bool -> Action a -neverMind b = abortIfWith b "never mind" - --- | Abort, and print the given message if the condition is true. -abortIfWith :: Bool -> Message -> Action a -abortIfWith True msg = abortWith msg -abortIfWith False _ = abortWith "" - --- | Print message, await confirmation. Return value indicates --- if the player tried to abort/escape. -messageMoreConfirm :: ColorMode -> Message -> Action Bool -messageMoreConfirm dm msg = do - messageAdd (msg ++ more) - displayGeneric dm id - session getConfirm - --- | Print message, await confirmation, ignore confirmation. -messageMore :: Message -> Action () -messageMore msg = messageClear >> messageMoreConfirm ColorFull msg >> return () - --- | Print a yes/no question and return the player's answer. -messageYesNo :: Message -> Action Bool -messageYesNo msg = do - messageReset (msg ++ yesno) - displayGeneric ColorBW id -- turn player's attention to the choice - session getYesNo - --- | Print a message and an overlay, await confirmation. Return value --- indicates if the player tried to abort/escape. -messageOverlayConfirm :: Message -> String -> Action Bool -messageOverlayConfirm msg txt = messageOverlaysConfirm msg [txt] - --- | Prints several overlays, one per page, and awaits confirmation. --- Return value indicates if the player tried to abort/escape. -messageOverlaysConfirm :: Message -> [String] -> Action Bool -messageOverlaysConfirm _msg [] = - do - messageClear - display - return True -messageOverlaysConfirm msg (x:xs) = - do - messageReset msg - b0 <- overlay (x ++ more) - if b0 - then do - b <- session getConfirm - if b - then messageOverlaysConfirm msg xs - else stop - else stop - where - stop = do - messageClear - display - return False - --- | Update the cached perception for the given computation. -withPerception :: Action () -> Action () -withPerception h = Action (\ s e _ k a st ms -> - runAction h s e (perception_ st) k a st ms) - --- | Get the current perception. -currentPerception :: Action Perceptions -currentPerception = Action (\ _s _e p k _a st ms -> k st ms p) - --- | If in targeting mode, check if the current level is the same --- as player level and refuse performing the action otherwise. -checkCursor :: Action () -> Action () -checkCursor h = do - cursor <- gets scursor - slid <- gets slid - if creturnLn cursor == slid - then h - else abortWith "this command does not work on remote levels" - -updateAnyActor :: ActorId -> (Actor -> Actor) -> Action () -updateAnyActor actor f = modify (updateAnyActorBody actor f) - -updatePlayerBody :: (Actor -> Actor) -> Action () -updatePlayerBody f = do - pl <- gets splayer - updateAnyActor pl f - --- | Advance the move time for the given actor. -advanceTime :: ActorId -> Action () -advanceTime actor = do - time <- gets stime - let upd m = m { btime = time + aspeed (Kind.getKind (bkind m)) } - -- A hack to synchronize the whole party: - pl <- gets splayer - if actor == pl || isAHero actor - then do - modify (updateLevel (updateHeroes (IM.map upd))) - unless (isAHero pl) $ updatePlayerBody upd - else updateAnyActor actor upd - -playerAdvanceTime :: Action () -playerAdvanceTime = do - pl <- gets splayer - advanceTime pl diff --git a/src/Actions.hs b/src/Actions.hs deleted file mode 100644 --- a/src/Actions.hs +++ /dev/null @@ -1,676 +0,0 @@ -module Actions where - -import Control.Monad -import Control.Monad.State hiding (State, state) -import qualified Data.List as L -import qualified Data.IntMap as IM -import Data.Maybe -import qualified Data.Set as S - -import Utils.Assert -import Action -import Display hiding (display) -import Loc -import Dir -import Grammar -import qualified HighScores as H -import Item -import qualified Keys as K -import Level -import LevelState -import Actor -import ActorState -import Content.ActorKind -import ActorAdd -import Perception -import State -import qualified Config -import qualified Save -import EffectAction -import WorldLoc -import Tile -- TODO: qualified -import qualified Kind -import qualified Feature as F -import DungeonState - --- The Action stuff that is independent from ItemAction.hs. --- (Both depend on EffectAction.hs). - -displayHistory :: Action () -displayHistory = - do - hst <- gets shistory - messageOverlayConfirm "" (unlines hst) - abort - -dumpConfig :: Action () -dumpConfig = - do - config <- gets sconfig - let fn = "config.dump" - liftIO $ Config.dump fn config - abortWith $ "Current configuration dumped to file " ++ fn ++ "." - -saveGame :: Action () -saveGame = - do - b <- messageYesNo "Really save?" - if b - then do - -- Save the game state - state <- get - liftIO $ Save.saveGame state - ln <- gets slid - let total = calculateTotal state - status = H.Camping ln - go <- handleScores False status total - when go $ messageMore "See you soon, stronger and braver!" - end - else abortWith "Game resumed." - -quitGame :: Action () -quitGame = - do - b <- messageYesNo "Really quit?" - if b - then end -- no highscore display for quitters - else abortWith "Game resumed." - --- | End targeting mode, accepting the current location or not. -endTargeting :: Bool -> Action () -endTargeting accept = do - returnLn <- gets (creturnLn . scursor) - target <- gets (btarget . getPlayerBody) - cloc <- gets (clocation . scursor) - -- return to the original level of the player - modify (\ state -> state{slid = returnLn}) - modify (updateCursor (\ c -> c { ctargeting = False })) - let isEnemy = case target of TEnemy _ _ -> True ; _ -> False - unless isEnemy $ - if accept - then updatePlayerBody (\ p -> p { btarget = TLoc cloc }) - else updatePlayerBody (\ p -> p { btarget = TCursor }) - endTargetingMsg - -endTargetingMsg :: Action () -endTargetingMsg = do - pbody <- gets getPlayerBody - state <- get - lxsize <- gets (lxsize . slevel) - let verb = "target" - targetMsg = case btarget pbody of - TEnemy a _ll -> - if memActor a state - then objectActor $ getActor a state - else "a fear of the past" - TLoc loc -> "location " ++ show (fromLoc lxsize loc) - TCursor -> "current cursor position continuously" - messageAdd $ subjectActorVerb pbody verb ++ " " ++ targetMsg ++ "." - --- | Cancel something, e.g., targeting mode, resetting the cursor --- to the position of the player. Chosen target is not invalidated. -cancelCurrent :: Action () -cancelCurrent = do - targeting <- gets (ctargeting . scursor) - if targeting - then endTargeting False - else abortWith "Press Q to quit." - --- | Accept something, e.g., targeting mode, keeping cursor where it was. --- Or perform the default action, if nothing needs accepting. -acceptCurrent :: Action () -> Action () -acceptCurrent h = do - targeting <- gets (ctargeting . scursor) - if targeting - then endTargeting True - else h -- nothing to accept right now - -moveCursor :: Dir -> Int -> Action () -moveCursor dir n = do - lxsize <- gets (lxsize . slevel) - lysize <- gets (lysize . slevel) - let upd cursor = - let boundedShift loc = - let (sx, sy) = fromLoc lxsize (loc `shift` dir) - (bx, by) = (max 1 $ min sx (lxsize - 2), - max 1 $ min sy (lysize - 2)) - in toLoc lxsize (bx, by) - cloc = iterate boundedShift (clocation cursor) !! n - in cursor{ clocation = cloc } - modify (updateCursor upd) - doLook - --- TODO: Think about doing the mode dispatch elsewhere, especially if over --- time more and more commands need to do the dispatch inside their code --- (currently only a couple do). -move :: Dir -> Action () -move dir = do - pl <- gets splayer - targeting <- gets (ctargeting . scursor) - if targeting then moveCursor dir 1 else moveOrAttack True True pl dir - -run :: Dir -> Action () -run dir = do - pl <- gets splayer - targeting <- gets (ctargeting . scursor) - if targeting - then moveCursor dir 10 - else do - updatePlayerBody (\ p -> p { bdir = Just dir }) - -- attacks and opening doors disallowed while running - moveOrAttack False False pl dir - --- | This function implements the actual "logic" of running. It checks if we --- have to stop running because something interested happened, and it checks --- if we have to adjust the direction because we're in the corner of a corridor. -continueRun :: Dir -> Action () -continueRun dir = - do - loc <- gets (bloc . getPlayerBody) - per <- currentPerception - msg <- currentMessage - ms <- gets (lmonsters . slevel) - hs <- gets (lheroes . slevel) - lxsize <- gets (lxsize . slevel) - lvl <- gets slevel - pl <- gets splayer - let dms = case pl of - AMonster n -> IM.delete n ms -- don't be afraid of yourself - AHero _ -> ms - mslocs = S.fromList (L.map bloc (IM.elems dms)) - monstersVisible = not (S.null (mslocs `S.intersection` ptvisible per)) - newsReported = not (L.null msg) - tile = lvl `rememberAt` loc -- tile at current location - itemsHere = not (L.null (lvl `irememberAt` loc)) - heroThere = (loc `shift` dir) `elem` L.map bloc (IM.elems hs) - dirOK = accessible lvl loc (loc `shift` dir) - isTExit = Tile.isExit tile - isWalkableDark = Tile.isWalkable tile && not (Tile.isLit tile) - -- What happens next is mostly depending on the terrain we're currently on. - let hop | (monstersVisible || heroThere || newsReported || - itemsHere || isTExit) = abort - | isWalkableDark = - -- in corridors, explore all corners and stop at all crossings - -- TODO: even in corridors, stop if you run past an exit (rare) - let ns = L.filter (\ x -> dirDistSq lxsize (neg dir) x > 1 - && (accessible lvl loc (loc `shift` x)) - || openable lvl (SecretStrength 1) (loc `shift` x)) - (moves lxsize) - allCloseTo main = L.all (\ d -> dirDistSq lxsize main d <= 1) ns - in case ns of - [onlyDir] -> run onlyDir -- can be diagonal - _ -> - -- prefer orthogonal to diagonal dirs, for hero's safety - case L.filter (not . diagonal lxsize) ns of - [ortoDir] - | allCloseTo ortoDir -> run ortoDir - _ -> abort - | not dirOK = - abort -- outside corridors never change direction - | otherwise = - let ns = L.filter (\ x -> x /= dir && dirDistSq lxsize (neg dir) x > 1) (moves lxsize) - ls = L.map (loc `shift`) ns - as = L.filter (\ x -> accessible lvl loc x - || openable lvl (SecretStrength 1) x) ls - ts = L.map (lvl `rememberAt`) as - in if L.any Tile.isExit ts then abort else run dir - hop - -ifRunning :: (Dir -> Action a) -> Action a -> Action a -ifRunning t e = - do - ad <- gets (bdir . getPlayerBody) - maybe e t ad - --- | Update player memory. -remember :: Action () -remember = - do - per <- currentPerception - lvl <- gets slevel - let vis = S.toList (ptvisible per) - let rememberTile = [(loc, lvl `at` loc) | loc <- vis] - modify (updateLevel (updateLRMap (Kind.// rememberTile))) - let alt Nothing = Nothing - alt (Just ([], _)) = Nothing - alt (Just (t, _)) = Just (t, t) - rememberItem = IM.alter alt - modify (updateLevel (updateIMap (\ m -> L.foldr rememberItem m vis))) - --- | Ask for a direction and close the door, if any -closeDoor :: Action () -closeDoor = do - messageReset "direction?" - display - e <- session nextCommand - lxsize <- gets (lxsize . slevel) - K.handleDirection lxsize e playerCloseDoor (neverMind True) - --- | Player closes a door. AI never does. -playerCloseDoor :: Dir -> Action () -playerCloseDoor dir = do - state <- get - lvl <- gets slevel - pl <- gets splayer - body <- gets (getActor pl) - let hms = levelHeroList state ++ levelMonsterList state - dloc = shift (bloc body) dir -- the location we act upon - t = lvl `at` dloc - if hasFeature F.Closable t - then - case lvl `iat` dloc of - [] -> - if unoccupied hms dloc - then let adj = (Kind.// [(dloc, Tile.doorClosedId)]) - in modify (updateLevel (updateLMap adj)) - else abortWith "blocked" -- by monsters or heroes - _:_ -> abortWith "jammed" -- by items - else if hasFeature F.Openable t - then abortWith "already closed" - else neverMind True -- no visible doors (can be secret) - advanceTime pl - --- | An actor closes a door. Player (hero or monster) or enemy. -actorOpenDoor :: ActorId -> Dir -> Action () -actorOpenDoor actor dir = do - lvl <- gets slevel - pl <- gets splayer - body <- gets (getActor actor) - let dloc = shift (bloc body) dir -- the location we act upon - t = lvl `at` dloc - isPlayer = actor == pl - isVerbose = isPlayer -- don't report enemy failures, if it's not player - iq = aiq $ Kind.getKind $ bkind body - openPower = SecretStrength $ - if isPlayer - then 1 -- player can't open secret doors - else case strongestItem (bitems body) "ring" of -- TODO: hack - Just i -> iq + jpower i - Nothing -> iq - unless (openable lvl openPower dloc) $ neverMind isVerbose - if hasFeature F.Closable t - then abortIfWith isVerbose "already open" - else if not (hasFeature F.Closable t || - hasFeature F.Openable t || - hasFeature F.Hidden t) - then neverMind isVerbose -- not doors at all - else - let adj = (Kind.// [(dloc, Tile.doorOpenId)]) - in modify (updateLevel (updateLMap adj)) - advanceTime actor - --- | Attempt a level switch to k levels shallower. --- TODO: perhaps set up some level name arithmetics in Level.hs --- and hide there the fact levels are now essentially Ints. -lvlAscend :: Int -> Action () -lvlAscend k = - do - slid <- gets slid - config <- gets sconfig - let n = levelNumber slid - nln = n - k - depth = Config.get config "dungeon" "depth" - when (nln < 1 || nln > depth) $ - abortWith "no more levels in this direction" - modify (\ state -> state{slid = (LambdaCave nln)}) - --- | Attempt a level change via up level and down level keys. --- Will quit the game if the player leaves the dungeon. -lvlGoUp :: Bool -> Action () -lvlGoUp isUp = - do - cursor <- gets scursor - targeting <- gets (ctargeting . scursor) - pbody <- gets getPlayerBody - pl <- gets splayer - slid <- gets slid - lvl <- gets slevel - st <- get - let loc = if targeting then clocation cursor else bloc pbody - tile = lvl `at` loc - vdir = if isUp then 1 else -1 - sdir | hasFeature F.Climbable tile = Just 1 - | hasFeature F.Descendable tile = Just (-1) - | otherwise = Nothing - case sdir of - Just vdir' - | vdir == vdir' -> -- stairs are in the right direction - case whereTo st loc of - Nothing -> - -- we are at the "end" of the dungeon - if targeting - then abortWith "cannot escape dungeon in targeting mode" - else do - b <- messageYesNo "Really escape the dungeon?" - if b - then fleeDungeon - else abortWith "Game resumed." - Just (nln, nloc) -> - if targeting - then do - assert (nln /= slid `blame` (nln, "stairs looped")) $ - modify (\ state -> state{slid = nln}) - -- do not freely reveal the other end of the stairs - lvl2 <- gets slevel - let upd cur = - let clocation = if isUnknown (lvl2 `rememberAt` nloc) - then loc - else nloc - in cur { clocation, clocLn = nln } - modify (updateCursor upd) - doLook - else tryWith (abortWith "somebody blocks the staircase") $ do - -- Remove the player from the old level. - modify (deleteActor pl) - hs <- gets levelHeroList - -- Monsters hear that players not on the level. Cancel smell. - -- Reduces memory load and savefile size. - when (L.null hs) $ - modify (updateLevel (updateSmell (const IM.empty))) - -- At this place the invariant that the player exists fails. - -- Change to the new level (invariant not needed). - assert (nln /= slid `blame` (nln, "stairs looped")) $ - modify (\ state -> state{slid = nln}) - -- Add the player to the new level. - modify (insertActor pl pbody) - -- At this place the invariant is restored again. - -- Land the player at the other end of the stairs. - updatePlayerBody (\ p -> p { bloc = nloc }) - -- Change the level of the player recorded in cursor. - modify (updateCursor (\ c -> c { creturnLn = nln })) - -- Bail out if anybody blocks the staircase. - inhabitants <- gets (locToActors nloc) - when (length inhabitants > 1) abort - -- The invariant "at most one actor on a tile" restored. - -- Create a backup of the savegame. - state <- get - liftIO $ do - Save.saveGame state - Save.mvBkp (sconfig state) - playerAdvanceTime - _ -> -- no stairs in the right direction - if targeting - then do - lvlAscend vdir - let upd cur = cur {clocLn = slid} - modify (updateCursor upd) - doLook - else - let txt = if isUp then "up" else "down" - in abortWith ("no stairs " ++ txt) - --- | Hero has left the dungeon. -fleeDungeon :: Action () -fleeDungeon = - do - state <- get - let total = calculateTotal state - items = L.concatMap bitems (levelHeroList state) - if total == 0 - then do - go <- messageClear >> messageMoreConfirm ColorFull "Coward!" - when go $ - messageMore "Next time try to grab some loot before escape!" - end - else do - let winMsg = "Congratulations, you won! Your loot, worth " ++ - show total ++ " gold, is:" - displayItems winMsg True items - go <- session getConfirm - when go $ do - go2 <- handleScores True H.Victor total - when go2 $ messageMore "Can it be done better, though?" - end - --- | Switches current hero to the next hero on the level, if any, wrapping. -cycleHero :: Action () -cycleHero = - do - pl <- gets splayer - hs <- gets (lheroes . slevel) - let i = case pl of AHero n -> n ; _ -> -1 - (lt, gt) = IM.split i hs - case IM.keys gt ++ IM.keys lt of - [] -> abortWith "Cannot select another hero on this level." - ni : _ -> selectPlayer (AHero ni) - >>= assert `trueM` (pl, ni, "hero duplicated") - --- | Search for secret doors -search :: Action () -search = - do - lm <- gets (lmap . slevel) - le <- gets (lsecret . slevel) - lxsize <- gets (lxsize . slevel) - ploc <- gets (bloc . getPlayerBody) - pitems <- gets (bitems . getPlayerBody) - let delta = case strongestItem pitems "ring" of - Just i -> 1 + jpower i - Nothing -> 1 - searchTile loc (slm, sle) = - let t = lm Kind.! loc - k = secretStrength (le IM.! loc) - delta - in if hasFeature F.Hidden t - then if k > 0 - then (slm, - IM.insert loc (SecretStrength k) sle) - else ((loc, Tile.doorClosedId) : slm, - IM.delete loc sle) - else (slm, sle) - f (slm, sle) m = searchTile (shift ploc m) (slm, sle) - (lmDiff, lemap) = L.foldl' f ([], le) (moves lxsize) - lmNew = if L.null lmDiff then lm else lm Kind.// lmDiff - modify (updateLevel (\ l -> l{lmap = lmNew, lsecret = lemap})) - playerAdvanceTime - --- | Start the floor targeting mode or reset the cursor location to the player. -targetFloor :: Action () -targetFloor = do - ploc <- gets (bloc . getPlayerBody) - target <- gets (btarget . getPlayerBody) - targeting <- gets (ctargeting . scursor) - let tgt = case target of - _ | targeting -> TLoc ploc -- double key press: reset cursor - TEnemy _ _ -> TCursor -- forget enemy target, keep the cursor - t -> t -- keep the target from previous targeting session - updatePlayerBody (\ p -> p { btarget = tgt }) - setCursor - --- | Start the monster targeting mode. Cycle between monster targets. --- TODO: also target a monster by moving the cursor, if in target monster mode. --- TODO: sort monsters by distance to the player. -targetMonster :: Action () -targetMonster = do - pl <- gets splayer - ms <- gets (lmonsters . slevel) - per <- currentPerception - target <- gets (btarget . getPlayerBody) - targeting <- gets (ctargeting . scursor) - let i = case target of - TEnemy (AMonster n) _ | targeting -> n -- try next monster - TEnemy (AMonster n) _ -> n - 1 -- try to retarget old monster - _ -> -1 -- try to target first monster (e.g., number 0) - dms = case pl of - AMonster n -> IM.delete n ms -- don't target yourself - AHero _ -> ms - (lt, gt) = IM.split i dms - gtlt = IM.assocs gt ++ IM.assocs lt - lf = L.filter (\ (_, m) -> actorSeesLoc pl (bloc m) per (Just pl)) gtlt - tgt = case lf of - [] -> target -- no monsters in sight, stick to last target - (na, nm) : _ -> TEnemy (AMonster na) (bloc nm) -- pick the next - updatePlayerBody (\ p -> p { btarget = tgt }) - setCursor - --- | Set, activate and display cursor information. -setCursor :: Action () -setCursor = do - state <- get - per <- currentPerception - ploc <- gets (bloc . getPlayerBody) - clocLn <- gets slid - let upd cursor = - let clocation = fromMaybe ploc (targetToLoc (ptvisible per) state) - in cursor { ctargeting = True, clocation, clocLn } - modify (updateCursor upd) - doLook - --- | Perform look around in the current location of the cursor. --- TODO: depending on tgt, show extra info about tile or monster or both -doLook :: Action () -doLook = - do - loc <- gets (clocation . scursor) - state <- get - lvl <- gets slevel - per <- currentPerception - target <- gets (btarget . getPlayerBody) - let canSee = S.member loc (ptvisible per) - monsterMsg = - if canSee - then case L.find (\ m -> bloc m == loc) (levelMonsterList state) of - Just m -> subjectActor m ++ " is here. " - Nothing -> "" - else "" - mode = case target of - TEnemy _ _ -> "[targeting monster] " - TLoc _ -> "[targeting location] " - TCursor -> "[targeting current] " - -- general info about current loc - lookMsg = mode ++ lookAt True canSee state lvl loc monsterMsg - -- check if there's something lying around at current loc - is = lvl `irememberAt` loc - if length is <= 2 - then do - messageAdd lookMsg - else do - displayItems lookMsg False is - session getConfirm - messageAdd "" - --- | This function performs a move (or attack) by any actor, --- i.e., it can handle monsters, heroes and both. -moveOrAttack :: Bool -> -- allow attacks? - Bool -> -- auto-open doors on move - ActorId -> -- who's moving? - Dir -> - Action () -moveOrAttack allowAttacks autoOpen actor dir = do - -- We start by looking at the target position. - state <- get - pl <- gets splayer - lvl <- gets slevel - sm <- gets (getActor actor) - let sloc = bloc sm -- source location - tloc = sloc `shift` dir -- target location - tgt <- gets (locToActor tloc) - case tgt of - Just target - | allowAttacks -> - -- Attacking does not require full access, adjacency is enough. - actorAttackActor actor target - | accessible lvl sloc tloc -> do - -- Switching positions requires full access. - actorRunActor actor target - when (actor == pl) $ - messageAdd $ lookAt False True state lvl tloc "" - | otherwise -> abortWith "" - Nothing - | accessible lvl sloc tloc -> do - -- perform the move - updateAnyActor actor $ \ body -> body {bloc = tloc} - when (actor == pl) $ - messageAdd $ lookAt False True state lvl tloc "" - advanceTime actor - | allowAttacks && actor == pl - && canBeSecretDoor (lvl `rememberAt` tloc) - -> do - messageAdd "You search your surroundings." -- TODO: proper msg - search - | autoOpen -> actorOpenDoor actor dir -- try to open a door - | otherwise -> abortWith "" - --- | Resolves the result of an actor moving into another. Usually this --- involves melee attack, but with two heroes it just changes focus. --- Actors on blocked locations can be attacked without any restrictions. --- For instance, an actor capable of moving through walls --- can be attacked from an adjacent position. --- This function is analogous to zapGroupItem, but for melee --- and not using up the weapon. -actorAttackActor :: ActorId -> ActorId -> Action () -actorAttackActor source@(AHero _) target@(AHero _) = - -- Select adjacent hero by bumping into him. Takes no time. - selectPlayer target - >>= assert `trueM` (source, target, "player bumps into himself") -actorAttackActor source target = do - state <- get - sm <- gets (getActor source) - tm <- gets (getActor target) - per <- currentPerception - let groupName = "sword" - verb = attackToVerb groupName - sloc = bloc sm - -- The hand-to-hand "weapon", equivalent to +0 sword. - h2h = Item Item.fistKindId 0 Nothing 1 - str = strongestItem (bitems sm) groupName - stack = fromMaybe h2h str - single = stack { jcount = 1 } - -- The message describes the source part of the action. - -- TODO: right now it also describes the victim and weapon; - -- perhaps, when a weapon is equipped, just say "you hit" or "you miss" - -- and then "nose dies" or "nose yells in pain". - msg = subjectVerbMObject sm verb tm $ - if isJust str then " with " ++ objectItem state single else "" - when (sloc `S.member` ptvisible per) $ messageAdd msg - -- Messages inside itemEffectAction describe the target part. - itemEffectAction 0 source target single - advanceTime source - -attackToVerb :: String -> String -attackToVerb "sword" = "hit" -- TODO: "slash"? "pierce"? "swing"? -attackToVerb "mace" = "bludgeon" -attackToVerb _ = "hit" - --- | Resolves the result of an actor running into another. --- This involves switching positions of the two actors. -actorRunActor :: ActorId -> ActorId -> Action () -actorRunActor source target = do - pl <- gets splayer - sloc <- gets (bloc . getActor source) -- source location - tloc <- gets (bloc . getActor target) -- target location - updateAnyActor source $ \ m -> m { bloc = tloc } - updateAnyActor target $ \ m -> m { bloc = sloc } - if source == pl - then stopRunning -- do not switch positions repeatedly - else when (isAMonster source) $ focusIfAHero target - advanceTime source - --- | Generate a monster, possibly. -generateMonster :: Action () -generateMonster = do - state <- get - nstate <- rndToAction $ rollMonster state - srandom <- gets srandom - put $ nstate{srandom} - --- | Possibly regenerate HP for all actors on the current level. -regenerateLevelHP :: Action () -regenerateLevelHP = - do - time <- gets stime - let upd m = - let ak = Kind.getKind $ bkind m - regen = aregen ak `div` - case strongestItem (bitems m) "amulet" of - Just i -> jpower i - Nothing -> 1 - in if time `mod` regen /= 0 - then m - else addHp 1 m - -- We really want hero selection to be a purely UI distinction, - -- so all heroes need to regenerate, not just the player. - -- Only the heroes on the current level regenerate (others are frozen - -- in time together with their level). This prevents cheating - -- via sending one hero to a safe level and waiting there. - modify (updateLevel (updateHeroes (IM.map upd))) - modify (updateLevel (updateMonsters (IM.map upd))) diff --git a/src/Actor.hs b/src/Actor.hs deleted file mode 100644 --- a/src/Actor.hs +++ /dev/null @@ -1,114 +0,0 @@ -module Actor where - -import Data.Binary -import Control.Monad -import qualified Data.IntMap as IM - -import Utils.Assert -import Geometry -import Dir -import Loc -import Item -import Content.ActorKind -import qualified Kind -import Random - --- | Monster properties that are changing a lot. If they are dublets --- of properties form ActorKind, the intention is they may be modified --- temporarily, but tend to return to the original value over time. E.g., HP. -data Actor = Actor - { bkind :: !(Kind.Id ActorKind) -- ^ the kind of the actor - , bname :: !(Maybe String) -- ^ individual name - , bsymbol :: !(Maybe Char) -- ^ individual map symbol - , bhp :: !Int -- ^ current hit pints - , bdir :: !(Maybe Dir) -- ^ the direction of running - , btarget :: Target -- ^ the target for distance attacks and AI - , bloc :: !Loc -- ^ current location - , bitems :: [Item] -- ^ inventory - , bletter :: !Char -- ^ next inventory letter - , btime :: !Time -- ^ time of next action - } - deriving Show - -instance Binary Actor where - put (Actor ak an as ah ad at al ai ale ati) = do - put ak - put an - put as - put ah - put ad - put at - put al - put ai - put ale - put ati - get = do - ak <- get - an <- get - as <- get - ah <- get - ad <- get - at <- get - al <- get - ai <- get - ale <- get - ati <- get - return (Actor ak an as ah ad at al ai ale ati) - -data ActorId = AHero !Int -- ^ hero index (on the lheroes intmap) - | AMonster !Int -- ^ monster index (on the lmonsters intmap) - deriving (Show, Eq, Ord) - -type Party = IM.IntMap Actor - -isAHero :: ActorId -> Bool -isAHero (AHero _) = True -isAHero (AMonster _) = False - -isAMonster :: ActorId -> Bool -isAMonster = not . isAHero - -addHp :: Int -> Actor -> Actor -addHp extra m = - assert (extra >= 0 `blame` extra) $ - let maxHP = maxDice (ahp $ Kind.getKind $ bkind m) - currentHP = bhp m - in if currentHP > maxHP - then m - else m{bhp = min maxHP (currentHP + extra)} - --- Checks for the presence of actors. Does *not* check if the tile is open. -unoccupied :: [Actor] -> Loc -> Bool -unoccupied actors loc = - all (\ body -> bloc body /= loc) actors - -heroKindId :: Kind.Id ActorKind -heroKindId = Kind.getId ((== "hero") . aname) - -instance Binary ActorId where - put (AHero n) = putWord8 0 >> put n - put (AMonster n) = putWord8 1 >> put n - get = do - tag <- getWord8 - case tag of - 0 -> liftM AHero get - 1 -> liftM AMonster get - _ -> fail "no parse (ActorId)" - -data Target = - TEnemy ActorId Loc -- ^ fire at the actor; last seen location - | TLoc Loc -- ^ fire at a given location - | TCursor -- ^ fire at the current position of the cursor; default - deriving (Show, Eq) - -instance Binary Target where - put (TEnemy a ll) = putWord8 0 >> put a >> put ll - put (TLoc loc) = putWord8 1 >> put loc - put TCursor = putWord8 2 - get = do - tag <- getWord8 - case tag of - 0 -> liftM2 TEnemy get get - 1 -> liftM TLoc get - 2 -> return TCursor - _ -> fail "no parse (Target)" diff --git a/src/ActorAdd.hs b/src/ActorAdd.hs deleted file mode 100644 --- a/src/ActorAdd.hs +++ /dev/null @@ -1,114 +0,0 @@ -module ActorAdd where - -import qualified Data.IntMap as IM -import qualified Data.IntSet as IS -import qualified Data.List as L -import Data.Ratio -import Data.Maybe -import qualified Data.Char as Char - -import Utils.Assert -import Loc -import State -import Level -import Actor -import ActorState -import Content.ActorKind -import Random -import qualified Config -import WorldLoc -import qualified Tile -import qualified Kind - --- Generic functions - --- Setting the time of new monsters to 0 makes them able to --- move immediately after generation. This does not seem like --- a bad idea, but it would certainly be "more correct" to set --- the time to the creation time instead. -template :: Kind.Id ActorKind -> Maybe String -> Maybe Char -> Int -> Loc - -> Actor -template mk ms mc hp loc = Actor mk ms mc hp Nothing TCursor loc [] 'a' 0 - -nearbyFreeLoc :: Loc -> State -> Loc -nearbyFreeLoc origin state = - let lvl@Level{lxsize, lysize} = slevel state - hs = levelHeroList state - ms = levelMonsterList state - places = origin : L.nub (concatMap (surroundings lxsize lysize) places) - good loc = Tile.isWalkable (lvl `at` loc) - && loc `L.notElem` L.map bloc (hs ++ ms) - in fromMaybe (assert `failure` "too crowded map") $ L.find good places - --- Adding heroes - -findHeroName :: Config.CP -> Int -> String -findHeroName config n = - let heroName = Config.getOption config "heroes" ("HeroName_" ++ show n) - in fromMaybe ("hero number " ++ show n) heroName - --- | Create a new hero on the current level, close to the given location. -addHero :: Loc -> State -> State -addHero ploc state = - let config = sconfig state - bHP = Config.get config "heroes" "baseHP" - loc = nearbyFreeLoc ploc state - n = fst (scounter state) - symbol = if n < 1 || n > 9 then Nothing else Just $ Char.intToDigit n - name = findHeroName config n - startHP = bHP `div` min 10 (n + 1) - m = template Actor.heroKindId (Just name) symbol startHP loc - state' = state { scounter = (n + 1, snd (scounter state)) - , sparty = IS.insert n (sparty state) } - in updateLevel (updateHeroes (IM.insert n m)) state' - --- | Create a set of initial heroes on the current level, at location ploc. -initialHeroes :: Loc -> State -> State -initialHeroes ploc state = - let k = 1 + Config.get (sconfig state) "heroes" "extraHeroes" - in iterate (addHero ploc) state !! k - --- Adding monsters - --- | Chance that a new monster is generated. Currently depends on the --- number of monsters already present, and on the level. In the future, --- the strength of the character and the strength of the monsters present --- could further influence the chance, and the chance could also affect --- which monster is generated. -monsterGenChance :: LevelId -> Int -> Rnd Bool -monsterGenChance (LambdaCave d) numMonsters = - chance $ 1%(fromIntegral (250 + 200 * (numMonsters - d)) `max` 50) - --- | Create a new monster in the level, at a random position. -addMonster :: Kind.Id ActorKind -> Int -> Loc -> State -> State -addMonster mk hp ploc state = do - let loc = nearbyFreeLoc ploc state - n = snd (scounter state) - m = template mk Nothing Nothing hp loc - state' = state { scounter = (fst (scounter state), n + 1) } - updateLevel (updateMonsters (IM.insert n m)) state' - --- | Create a new monster in the level, at a random position. -rollMonster :: State -> Rnd State -rollMonster state = do - let lvl = slevel state - hs = levelHeroList state - ms = levelMonsterList state - rc <- monsterGenChance (slid state) (L.length ms) - if not rc - then return state - else do - -- TODO: new monsters should always be generated in a place that isn't - -- visible by the player (if possible -- not possible for bigrooms) - -- levels with few rooms are dangerous, because monsters may spawn - -- in adjacent and unexpected places - loc <- findLocTry 2000 (lmap lvl) - (\ l t -> Tile.isWalkable t - && l `L.notElem` L.map bloc (hs ++ ms)) - (\ l t -> not (Tile.isLit t) -- try a dark, distant place first - && L.all (\ pl -> distance - (lxsize lvl) - (bloc pl) l > 30) hs) - (mk, k) <- frequency Kind.frequency - hp <- rollDice $ ahp k - return $ addMonster mk hp loc state diff --git a/src/ActorState.hs b/src/ActorState.hs deleted file mode 100644 --- a/src/ActorState.hs +++ /dev/null @@ -1,136 +0,0 @@ -module ActorState where - -import qualified Data.List as L -import qualified Data.Set as S -import qualified Data.IntSet as IS -import qualified Data.IntMap as IM -import Control.Monad -import Data.Maybe - -import Utils.Assert -import Loc -import Actor -import Level -import qualified Dungeon -import State -import WorldLoc - --- The operations with "Any", and those that use them, consider all the dungeon. --- All the other actor and level operations only consider the current level. - --- | Finds an actor body on any level. Fails if not found. -findActorAnyLevel :: ActorId -> State -> (LevelId, Actor) -findActorAnyLevel actor state@State{slid, sdungeon} = - assert (not (absentHero actor state) `blame` actor) $ - let chk (ln, lvl) = - fmap (\ m -> (ln, m)) $ - case actor of - AHero n -> IM.lookup n (lheroes lvl) - AMonster n -> IM.lookup n (lmonsters lvl) - in case mapMaybe chk (Dungeon.currentFirst slid sdungeon) of - [] -> assert `failure` actor - res:_ -> res -- checking if res is unique would break laziness - --- | Checks whether an actor is a hero, but not a member of the party. -absentHero :: ActorId -> State -> Bool -absentHero a State{sparty} = - case a of - AHero n -> IS.notMember n sparty - AMonster _ -> False - -getPlayerBody :: State -> Actor -getPlayerBody state = - let pl = splayer state - in snd $ findActorAnyLevel pl state - --- | The list of actors and levels for all heroes in the dungeon. -allHeroesAnyLevel :: State -> [(ActorId, LevelId)] -allHeroesAnyLevel State{slid, sdungeon} = - let one (ln, Level{lheroes}) = - L.map (\ (i, _) -> (AHero i, ln)) (IM.assocs lheroes) - in L.concatMap one (Dungeon.currentFirst slid sdungeon) - -updateAnyActorBody :: ActorId -> (Actor -> Actor) -> State -> State -updateAnyActorBody actor f state = - let (ln, _) = findActorAnyLevel actor state - in case actor of - AHero n -> updateAnyLevel (updateHeroes $ IM.adjust f n) ln state - AMonster n -> updateAnyLevel (updateMonsters $ IM.adjust f n) ln state - -updateAnyLevel :: (Level -> Level) -> LevelId -> State -> State -updateAnyLevel f ln state@State{slid, sdungeon} - | ln == slid = updateLevel f state - | otherwise = updateDungeon (const $ Dungeon.adjust f ln sdungeon) state - --- | Calculate the location of player's target. -targetToLoc :: S.Set Loc -> State -> Maybe Loc -targetToLoc visible state = - case btarget (getPlayerBody state) of - TLoc loc -> Just loc - TCursor -> - if slid state == clocLn (scursor state) - then Just $ clocation (scursor state) - else Nothing -- cursor invalid: set at a different level - TEnemy a _ll -> do - guard $ memActor a state -- alive and on the current level? - let loc = bloc (getActor a state) - guard $ S.member loc visible -- visible? - return loc - --- The operations below disregard levels other than the current. - --- | Checks if the actor is present on the current level. -memActor :: ActorId -> State -> Bool -memActor a state = - case a of - AHero n -> IM.member n (lheroes (slevel state)) - AMonster n -> IM.member n (lmonsters (slevel state)) - --- | Gets actor body from the current level. Error if not found. -getActor :: ActorId -> State -> Actor -getActor a state = - case a of - AHero n -> lheroes (slevel state) IM.! n - AMonster n -> lmonsters (slevel state) IM.! n - --- | Removes the actor, if present, from the current level. -deleteActor :: ActorId -> State -> State -deleteActor a = - case a of - AHero n -> updateLevel (updateHeroes (IM.delete n)) - AMonster n -> updateLevel (updateMonsters (IM.delete n)) - --- | Add actor to the current level. -insertActor :: ActorId -> Actor -> State -> State -insertActor a m = - case a of - AHero n -> updateLevel (updateHeroes (IM.insert n m)) - AMonster n -> updateLevel (updateMonsters (IM.insert n m)) - --- | Removes a player from the current level and party list. -deletePlayer :: State -> State -deletePlayer state@State{splayer, sparty} = - let s = deleteActor splayer state - in case splayer of - AHero n -> s{sparty = IS.delete n sparty} - AMonster _ -> s - -levelHeroList, levelMonsterList :: State -> [Actor] -levelHeroList state = IM.elems $ lheroes $ slevel state -levelMonsterList state = IM.elems $ lmonsters $ slevel state - --- | Finds an actor at a location on the current level. Perception irrelevant. -locToActor :: Loc -> State -> Maybe ActorId -locToActor loc state = - let l = locToActors loc state - in assert (L.length l <= 1 `blame` l) $ - listToMaybe l - -locToActors :: Loc -> State -> [ActorId] -locToActors loc state = - getIndex (lmonsters, AMonster) ++ getIndex (lheroes, AHero) - where - getIndex (projection, injection) = - let l = IM.assocs $ projection $ slevel state - im = L.filter (\ (_i, m) -> bloc m == loc) l - in fmap (injection . fst) im diff --git a/src/Area.hs b/src/Area.hs deleted file mode 100644 --- a/src/Area.hs +++ /dev/null @@ -1,51 +0,0 @@ -module Area - ( Area, neighbors, fromTo, normalize, normalizeArea, grid ) where - -import qualified Data.List as L - -import Geometry -import Utils.Assert - -type Area = (X, Y, X, Y) - -neighbors :: Area -> {- size limitation -} - (X, Y) -> {- location to find neighbors of -} - [(X, Y)] -neighbors area xy = - let cs = [ xy `shiftXY` (dx, dy) - | dy <- [-1..1], dx <- [-1..1], (dx + dy) `mod` 2 == 1 ] - in L.filter (`inside` area) cs - -inside :: (X, Y) -> Area -> Bool -inside (x, y) (x0, y0, x1, y1) = - x1 >= x && x >= x0 && y1 >= y && y >= y0 - -fromTo :: (X, Y) -> (X, Y) -> [(X, Y)] -fromTo (x0, y0) (x1, y1) = - let result - | x0 == x1 = L.map (\ y -> (x0, y)) (fromTo1 y0 y1) - | y0 == y1 = L.map (\ x -> (x, y0)) (fromTo1 x0 x1) - | otherwise = assert `failure` ((x0, y0), (x1, y1)) - in result - -fromTo1 :: Int -> Int -> [Int] -fromTo1 x0 x1 - | x0 <= x1 = [x0..x1] - | otherwise = [x0,x0-1..x1] - -normalize :: ((X, Y), (X, Y)) -> ((X, Y), (X, Y)) -normalize (a, b) | a <= b = (a, b) - | otherwise = (b, a) - -normalizeArea :: Area -> Area -normalizeArea (x0, y0, x1, y1) = (min x0 x1, min y0 y1, max x0 x1, max y0 y1) - -grid :: (X, Y) -> Area -> [((X, Y), Area)] -grid (nx, ny) (x0, y0, x1, y1) = - let yd = y1 - y0 - xd = x1 - x0 - in [ ((x, y), (x0 + (xd * x `div` nx), - y0 + (yd * y `div` ny), - x0 + (xd * (x + 1) `div` nx - 1), - y0 + (yd * (y + 1) `div` ny - 1))) - | x <- [0..nx-1], y <- [0..ny-1] ] diff --git a/src/AreaRnd.hs b/src/AreaRnd.hs deleted file mode 100644 --- a/src/AreaRnd.hs +++ /dev/null @@ -1,103 +0,0 @@ -module AreaRnd where - -import qualified Data.List as L -import qualified Data.Set as S -import qualified System.Random as R - -import Geometry -import Area -import Random - -xyInArea :: Area -> Rnd (X, Y) -xyInArea (x0, y0, x1, y1) = do - rx <- randomR (x0, x1) - ry <- randomR (y0, y1) - return (rx, ry) - -connectGrid' :: (X, Y) -> S.Set (X, Y) -> S.Set (X, Y) -> [((X, Y), (X, Y))] -> - Rnd [((X, Y), (X, Y))] -connectGrid' (nx, ny) unconnected candidates acc - | S.null candidates = return (L.map normalize acc) - | otherwise = do - c <- oneOf (S.toList candidates) - -- potential new candidates: - let ns = S.fromList $ neighbors (0, 0, nx-1, ny-1) c - nu = S.delete c unconnected -- new unconnected - -- (new candidates, potential connections): - (nc, ds) = S.partition (`S.member` nu) ns - new <- if S.null ds - then return id - else do - d <- oneOf (S.toList ds) - return ((c, d) :) - connectGrid' (nx, ny) nu (S.delete c (candidates `S.union` nc)) (new acc) - -connectGrid :: (X, Y) -> Rnd [((X, Y), (X, Y))] -connectGrid (nx, ny) = do - let unconnected = S.fromList [ (x, y) | x <- [0..nx-1], y <- [0..ny-1] ] - -- candidates are neighbors that are still unconnected; we start with - -- a random choice - rx <- randomR (0, nx-1) - ry <- randomR (0, ny-1) - let candidates = S.fromList [ (rx, ry) ] - connectGrid' (nx, ny) unconnected candidates [] - -randomConnection :: (X, Y) -> Rnd ((X, Y), (X, Y)) -randomConnection (nx, ny) = do - rb <- randomR (False, True) - if rb - then do - rx <- randomR (0, nx-2) - ry <- randomR (0, ny-1) - return (normalize ((rx, ry), (rx+1, ry))) - else do - ry <- randomR (0, ny-2) - rx <- randomR (0, nx-1) - return (normalize ((rx, ry), (rx, ry+1))) - -data HV = Horiz | Vert - deriving (Eq, Show, Bounded) - -fromHV :: HV -> Bool -fromHV Horiz = True -fromHV Vert = False - -toHV :: Bool -> HV -toHV True = Horiz -toHV False = Vert - -instance R.Random HV where - randomR (a, b0) g = case R.randomR (fromHV a, fromHV b0) g of - (b, g') -> (toHV b, g') - random = R.randomR (minBound, maxBound) - --- | Create a corridor, either horizontal or vertical, with --- a possible intermediate part that is in the opposite direction. -mkCorridor :: HV -> ((X, Y), (X, Y)) -> Area -> Rnd [(X, Y)] {- straight sections of the corridor -} -mkCorridor hv ((x0, y0), (x1, y1)) b = - do - (rx, ry) <- xyInArea b - -- (rx, ry) is intermediate point the path crosses - -- hv decides whether we start in horizontal or vertical direction - case hv of - Horiz -> return [(x0, y0), (rx, y0), (rx, y1), (x1, y1)] - Vert -> return [(x0, y0), (x0, ry), (x1, ry), (x1, y1)] - --- | Try to connect two rooms with a corridor. --- The condition passed to mkCorridor is tricky; there might not always --- exist a suitable intermediate point if the rooms are allowed to be close --- together ... -connectRooms :: Area -> Area -> Rnd [(X, Y)] -connectRooms sa@(_, _, sx1, sy1) ta@(tx0, ty0, _, _) = - do - (sx, sy) <- xyInArea sa - (tx, ty) <- xyInArea ta - let xok = sx1 < tx0 - 3 - let xarea = normalizeArea (sx1+2, sy, tx0-2, ty) - let yok = sy1 < ty0 - 3 - let yarea = normalizeArea (sx, sy1+2, tx, ty0-2) - let xyarea = normalizeArea (sx1+2, sy1+2, tx0-2, ty0-2) - (hv, area) <- if xok && yok then fmap (\ hv -> (hv, xyarea)) (binaryChoice Horiz Vert) - else if xok then return (Horiz, xarea) - else return (Vert, yarea) - mkCorridor hv ((sx, sy), (tx, ty)) area diff --git a/src/Bot.hs b/src/Bot.hs deleted file mode 100644 --- a/src/Bot.hs +++ /dev/null @@ -1,22 +0,0 @@ -module Main where - -import qualified System.Random as R -import System.Environment -import Control.Monad - -move :: R.StdGen -> Int -> IO () -move g k = do - let (c, ng) = R.randomR ('0', 'z') g - putChar c - when (k > 0) $ move ng (k - 1) - -main :: IO () -main = do - args <- getArgs - case args of - [seed, count] -> do - -- Start by dumping config (hack: ' ', see Std.hs) with the game seed. - putChar ' ' - -- Note that the seed is separate from the game seed. - move (R.mkStdGen (read seed)) (read count) - _ -> error "Two integer arguments required: random seed and iteration count." diff --git a/src/Cave.hs b/src/Cave.hs deleted file mode 100644 --- a/src/Cave.hs +++ /dev/null @@ -1,208 +0,0 @@ -module Cave - ( Cave(..), SecretMapXY, ItemMapXY, TileMapXY, buildCave ) where - -import Control.Monad -import qualified Data.Map as M -import qualified Data.List as L - -import Geometry -import Area -import AreaRnd -import Item -import Random -import Content.TileKind -import Tile -import qualified Kind -import Content.CaveKind - -type SecretMapXY = M.Map (X, Y) SecretStrength - -type ItemMapXY = M.Map (X, Y) Item - -type TileMapXY = M.Map (X, Y) (Kind.Id TileKind) - --- TODO: dmonsters :: [(X, Y), actorKind] -- ^ fixed monsters on the level -data Cave = Cave - { dkind :: !(Kind.Id CaveKind) -- ^ the kind of the cave - , dsecret :: SecretMapXY - , ditem :: ItemMapXY - , dmap :: TileMapXY - , dmeta :: String - } - deriving Show - -buildCave :: Int -> Kind.Id CaveKind -> Rnd Cave -buildCave n ci = - let CaveKind{clayout} = Kind.getKind ci - in case clayout of - CaveRogue -> caveRogue n ci - CaveEmpty -> caveEmpty n ci - CaveNoise -> caveNoise n ci - --- | Cave consisting of only one, empty room. -caveEmpty :: Int -> Kind.Id CaveKind -> Rnd Cave -caveEmpty _ ci = - let CaveKind{cxsize, cysize} = Kind.getKind ci - room = (1, 1, cxsize - 2, cysize - 2) - dmap = digRoom True room M.empty - cave = Cave - { dkind = ci - , dsecret = M.empty - , ditem = M.empty - , dmap - , dmeta = "empty room" - } - in return cave - --- | Cave consisting of only one room with randomly distributed pillars. -caveNoise :: Int -> Kind.Id CaveKind -> Rnd Cave -caveNoise _ ci = do - let CaveKind{cxsize, cysize} = Kind.getKind ci - room = (1, 1, cxsize - 2, cysize - 2) - em = digRoom True room M.empty - nri <- rollDice (fromIntegral (cysize `div` 5), 3) - lxy <- replicateM (cxsize * nri) $ xyInArea (1, 1, cxsize - 2, cysize - 2) - let insertRock lm xy = M.insert xy Tile.wallId lm - dmap = L.foldl' insertRock em lxy - cave = Cave - { dkind = ci - , dsecret = M.empty - , ditem = M.empty - , dmap - , dmeta = "noise room" - } - return cave - --- | If the room has size 1, it is at most a start of a corridor. -digRoom :: Bool -> Room -> TileMapXY -> TileMapXY -digRoom dl (x0, y0, x1, y1) lmap - | x0 == x1 && y0 == y1 = lmap - | otherwise = - let floorDL = if dl then Tile.floorLightId else Tile.floorDarkId - rm = - [ ((x, y), floorDL) | x <- [x0..x1], y <- [y0..y1] ] - ++ [ ((x, y), Tile.wallId) - | x <- [x0-1, x1+1], y <- [y0..y1] ] - ++ [ ((x, y), Tile.wallId) - | x <- [x0-1..x1+1], y <- [y0-1, y1+1] ] - in M.union (M.fromList rm) lmap - -{- -Rogue cave is generated by an algorithm inspired by the original Rogue, -as follows: - - * The available area is divided into a 3 by 3 grid - where each of the 9 grid cells has approximately the same size. - - * In each of the 9 grid cells one room is placed at a random location. - The minimum size of a room is 2 by 2 floor tiles. A room is surrounded - by walls, and the walls still have to fit into the assigned grid cells. - - * 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. --} --- | Cave generated by an algorithm inspired by the original Rogue, -caveRogue :: Int -> Kind.Id CaveKind -> Rnd Cave -caveRogue n ci = do - let cfg@CaveKind{cxsize, cysize} = Kind.getKind ci - lgrid@(gx, gy) <- levelGrid cfg - lminroom <- minRoomSize cfg - let gs = grid lgrid (0, 0, cxsize - 1, cysize - 1) - -- grid locations of "no-rooms" - nrnr <- noRooms cfg lgrid - nr <- replicateM nrnr $ xyInArea (0, 0, gx - 1, gy - 1) - rs0 <- mapM (\ (i, r) -> do - r' <- if i `elem` nr - then mkRoom (border cfg) (1, 1) r - else mkRoom (border cfg) lminroom r - return (i, r')) gs - let rooms :: [Area] - rooms = L.map snd rs0 - dlrooms <- mapM (\ r -> darkRoomChance cfg n - >>= \ c -> return (r, not c)) rooms - :: Rnd [(Area, Bool)] - let rs = M.fromList rs0 - connects <- connectGrid lgrid - addedConnects <- replicateM - (extraConnects cfg lgrid) - (randomConnection lgrid) - let allConnects = L.nub (addedConnects ++ connects) - cs <- mapM - (\ (p0, p1) -> do - let r0 = rs M.! p0 - r1 = rs M.! p1 - connectRooms r0 r1) allConnects - let lrooms = L.foldr (\ (r, dl) m -> digRoom dl r m) M.empty dlrooms - lcorridors = M.unions (L.map digCorridors cs) - lrocks = - M.fromList [ ((x, y), Tile.wallId) | x <- [0..cxsize - 1], y <- [0..cysize - 1] ] - lm = M.union (M.unionWith mergeCorridor lcorridors lrooms) lrocks - -- convert openings into doors - (dmap, secretMap) <- do - let f (l, le) o@((x, y), t) = - case t of - _ | Tile.isOpening t -> - do - -- openings have a certain chance to be doors; - -- doors have a certain chance to be open; and - -- closed doors have a certain chance to be - -- secret - rb <- doorChance cfg - ro <- doorOpenChance cfg - if not rb - then return (o : l, le) - else if ro - then return (((x, y), Tile.doorOpenId) : l, le) - else do - rsc <- doorSecretChance cfg - if not rsc - then return (((x, y), Tile.doorClosedId) : l, le) - else do - rs1 <- rollDice (csecretStrength cfg) - return (((x, y), Tile.doorSecretId) : l, M.insert (x, y) (SecretStrength rs1) le) - _ -> return (o : l, le) - (l, le) <- foldM f ([], M.empty) (M.toList lm) - return (M.fromList l, le) - let cave = Cave - { dkind = ci - , dsecret = secretMap - , ditem = M.empty - , dmap - , dmeta = show allConnects - } - return cave - -type Corridor = [(X, Y)] -type Room = Area - --- | Create a random room according to given parameters. -mkRoom :: Int -> -- ^ border columns - (X, Y) -> -- ^ minimum size - Area -> -- ^ this is an area, not the room itself - Rnd Room -- ^ this is the upper-left and lower-right corner of the room -mkRoom bd (xm, ym) (x0, y0, x1, y1) = - do - (rx0, ry0) <- xyInArea (x0 + bd, y0 + bd, x1 - bd - xm + 1, y1 - bd - ym + 1) - (rx1, ry1) <- xyInArea (rx0 + xm - 1, ry0 + ym - 1, x1 - bd, y1 - bd) - return (rx0, ry0, rx1, ry1) - -digCorridors :: Corridor -> TileMapXY -digCorridors (p1:p2:ps) = - M.union corPos (digCorridors (p2:ps)) - where - corXY = fromTo p1 p2 - corPos = M.fromList $ L.zip corXY (repeat Tile.floorDarkId) -digCorridors _ = M.empty - -mergeCorridor :: Kind.Id TileKind -> Kind.Id TileKind -> Kind.Id TileKind -mergeCorridor _ t | Tile.isWalkable t = t -mergeCorridor _ t | Tile.isUnknown t = Tile.floorDarkId -mergeCorridor _ _ = Tile.openingId diff --git a/src/Color.hs b/src/Color.hs deleted file mode 100644 --- a/src/Color.hs +++ /dev/null @@ -1,91 +0,0 @@ -module Color - (Color(..), Attr, defBG, defFG, defaultAttr, isBright, legalBG, colorToRGB) - where - -import qualified Data.Binary as Binary - --- TODO: if the file grows much larger, split into Utils/Color.hs and Attr.hs - --- TODO: since this type may be essential to speed, consider implementing --- it as an Int, with color numbered as they are on terminals, see --- http://www.haskell.org/haskellwiki/Performance/Data_types#Enumerations --- If we ever switch to 256 colours, the Int implementation or similar --- will be more natural, anyway. - -data Color = - Black - | Red - | Green - | Yellow - | Blue - | Magenta - | Cyan - | White - | BrBlack - | BrRed - | BrGreen - | BrYellow - | BrBlue - | BrMagenta - | BrCyan - | BrWhite - deriving (Show, Eq, Ord, Enum, Bounded) - -instance Binary.Binary Color where - put = Binary.putWord8 . toEnum . fromEnum - get = fmap (toEnum . fromEnum) Binary.getWord8 - -defBG, defFG :: Color -defBG = Black -defFG = White - -type Attr = (Color.Color, Color.Color) - -defaultAttr :: Attr -defaultAttr = (Color.defFG, Color.defBG) - -isBright :: Color -> Bool -isBright c = fromEnum c > 7 -- for terminals that display bright via bold - --- | Due to limitation of curses, only these are legal backgrounds. -legalBG :: [Color] -legalBG = [Black, White, Blue, Magenta] - --- Heavily modified Linux console colors. -colorToRGB :: Color -> String -colorToRGB Black = "#000000" -colorToRGB Red = "#D50000" -colorToRGB Green = "#00AA00" -colorToRGB Yellow = "#AA5500" -- brown -colorToRGB Blue = "#203AF0" -colorToRGB Magenta = "#AA00AA" -colorToRGB Cyan = "#00AAAA" -colorToRGB White = "#C5BCB8" -colorToRGB BrBlack = "#6F5F5F" -colorToRGB BrRed = "#FF5555" -colorToRGB BrGreen = "#75FF45" -colorToRGB BrYellow = "#FFE855" -colorToRGB BrBlue = "#4090FF" -colorToRGB BrMagenta = "#FF77FF" -colorToRGB BrCyan = "#60FFF0" -colorToRGB BrWhite = "#FFFFFF" - --- For reference, the original Linux console colors. --- Good old retro feel and more useful than xterm (e.g. brown). -_olorToRGB :: Color -> String -_olorToRGB Black = "#000000" -_olorToRGB Red = "#AA0000" -_olorToRGB Green = "#00AA00" -_olorToRGB Yellow = "#AA5500" -- brown -_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" diff --git a/src/Command.hs b/src/Command.hs deleted file mode 100644 --- a/src/Command.hs +++ /dev/null @@ -1,41 +0,0 @@ -module Command where - -import Action -import Actions -import Dir -import ItemAction -import Version - -data Described a = Described { chelp :: String, caction :: a } - | Undescribed { caction :: a } - -type Command = Described (Action ()) -type DirCommand = Described (Dir -> Action ()) - -closeCommand, pickupCommand, dropCommand, inventoryCommand, ascendCommand, descendCommand, floorCommand, monsterCommand, quaffCommand, readCommand, throwCommand, aimCommand, saveCommand, quitCommand, cancelCommand, historyCommand, dumpCommand, heroCommand, versionCommand :: Described (Action ()) -closeCommand = Described "close a door" (checkCursor closeDoor) -pickupCommand = Described "get an object" (checkCursor pickupItem) -dropCommand = Described "drop an object" (checkCursor dropItem) -inventoryCommand = Described "display inventory" inventory -ascendCommand = Described "ascend a level" (lvlGoUp True) -descendCommand = Described "descend a level" (lvlGoUp False) -floorCommand = Described "target location" targetFloor -monsterCommand = Described "target monster" (checkCursor targetMonster) -quaffCommand = Described "quaff a potion" (checkCursor quaffPotion) -readCommand = Described "read a scroll" (checkCursor readScroll) -throwCommand = Described "throw a weapon" (checkCursor throwItem) -aimCommand = Described "aim a wand" (checkCursor aimItem) -saveCommand = Described "save and exit the game" saveGame -quitCommand = Described "quit without saving" quitGame -cancelCommand = Described "cancel action" cancelCurrent -historyCommand = Described "display previous messages" displayHistory -dumpCommand = Described "dump current configuration" dumpConfig -heroCommand = Described "cycle among heroes on level" cycleHero -versionCommand = Described "display game version" (abortWith version) - -acceptCommand :: Action () -> Described (Action ()) -acceptCommand h = Described "accept choice" (acceptCurrent h) - -moveDirCommand, runDirCommand :: Described (Dir -> Action ()) -moveDirCommand = Described "move in direction" move -runDirCommand = Described "run in direction" run diff --git a/src/Config.hs b/src/Config.hs deleted file mode 100644 --- a/src/Config.hs +++ /dev/null @@ -1,118 +0,0 @@ -module Config - (CP, defaultCP, config, getOption, getItems, get, getFile, set, dump) where - -import System.Directory -import System.FilePath -import qualified Data.ConfigFile as CF -import qualified Data.Binary as Binary - -import qualified ConfigDefault - -newtype CP = CP CF.ConfigParser - -instance Binary.Binary CP where - put (CP conf) = Binary.put $ CF.to_string conf - get = do - string <- Binary.get - -- use config in case savegame is from older version and lacks some options - let c = CF.readstring defCF string - return $ toCP $ forceEither c - -instance Show CP where - show (CP conf) = show $ CF.to_string conf - -forceEither :: Show a => Either a b -> b -forceEither (Left a) = error (show a) -forceEither (Right b) = b - --- | Switches all names to case sensitive (unlike by default in ConfigFile). -toSensitive :: CF.ConfigParser -> CF.ConfigParser -toSensitive cp = cp {CF.optionxform = id} - --- | The default configuration taken from the default configuration file --- included via CPP in ConfigDefault.hs. -defCF :: CF.ConfigParser -defCF = - let c = CF.readstring CF.emptyCP ConfigDefault.configDefault - in toSensitive $ forceEither c - -toCP :: CF.ConfigParser -> CP -toCP cp = CP $ toSensitive cp - -defaultCP :: CP -defaultCP = toCP defCF - --- | Path to the user configuration file. -file :: IO FilePath -file = - do - appData <- getAppUserDataDirectory "Allure" - return $ combine appData "config" - --- | The configuration read from the user configuration file. --- The default configuration file provides underlying defaults --- in case some options, or the whole file, are missing. -config :: IO CP -config = - -- evaluate, to catch config errors ASAP - defCF `seq` - do - f <- file - b <- doesFileExist f - if not b - then return $ toCP defCF - else do - c <- CF.readfile defCF f - return $ toCP $ forceEither c - --- | A simplified access to an option in a given section, --- with simple error reporting (no error is caught and hidden). --- If there is no config file or no such option, gives Nothing. -getOption :: CF.Get_C a => CP -> CF.SectionSpec -> CF.OptionSpec -> Maybe a -getOption (CP conf) s o = - if CF.has_option conf s o - then Just $ forceEither $ CF.get conf s o - else Nothing - --- | Simplified access to an option in a given section. -get :: CF.Get_C a => CP -> CF.SectionSpec -> CF.OptionSpec -> a -get (CP conf) s o = - if CF.has_option conf s o - then forceEither $ CF.get conf s o - else error $ "Unknown config option: " ++ s ++ "." ++ o - --- | Simplified setting of an option in a given section. Overwriting forbidden. -set :: CP -> CF.SectionSpec -> CF.OptionSpec -> String -> CP -set (CP conf) s o v = - if CF.has_option conf s o - then error $ "Overwritten config option: " ++ s ++ "." ++ o - else CP $ forceEither $ CF.set conf s o v - --- | An association list corresponding to a section. -getItems :: CP -> CF.SectionSpec -> [(String, String)] -getItems (CP conf) s = - if CF.has_section conf s - then forceEither $ CF.items conf s - else error $ "Unknown config section: " ++ s - --- | Looks up a file path in the config file and makes it absolute. --- If the game's configuration directory exists, --- the path is appended to it; otherwise, it's appended --- to the current directory. -getFile :: CP -> CF.SectionSpec -> CF.OptionSpec -> IO FilePath -getFile conf s o = - do - current <- getCurrentDirectory - appData <- getAppUserDataDirectory "Allure" - let path = get conf s o - appPath = combine appData path - curPath = combine current path - b <- doesDirectoryExist appData - return $ if b then appPath else curPath - -dump :: FilePath -> CP -> IO () -dump fn (CP conf) = do - current <- getCurrentDirectory - let path = combine current fn - sdump = CF.to_string conf - writeFile path sdump diff --git a/src/ConfigDefault.hs b/src/ConfigDefault.hs --- a/src/ConfigDefault.hs +++ b/src/ConfigDefault.hs @@ -1,27 +1,22 @@ {-# LANGUAGE CPP, QuasiQuotes #-} - -module ConfigDefault (configDefault) where +-- Copyright (c) 2008--2011 Andres Loeh, 2010--2012 Mikolaj Konarski +-- This file is a part of the computer game Allure of the Stars +-- and is released under the terms of the GNU Affero General Public License. +-- For license and copyright information, see the file LICENSE. +-- +-- | The default configurations file included via CPP as a Haskell string. +module ConfigDefault ( configDefault ) where -import Utils.Multiline +import Multiline -- Consider code.haskell.org/~dons/code/compiled-constants (dead link, BTW?) -- as soon as the config file grows very big. -- | The string containing the default configuration --- included from file src/config.default. +-- included from file config.default. -- Warning: cabal does not detect that the default config is changed, -- so touching this file is needed to reinclude config and recompile. configDefault :: String configDefault = [multiline| - -#ifdef STD - -#include "config.bot" - -#else - -#include "config.default" - -#endif - +#include "../config.default" |] diff --git a/src/Content/ActorKind.hs b/src/Content/ActorKind.hs --- a/src/Content/ActorKind.hs +++ b/src/Content/ActorKind.hs @@ -1,79 +1,73 @@ -module Content.ActorKind (ActorKind(..)) where +-- Copyright (c) 2008--2011 Andres Loeh, 2010--2012 Mikolaj Konarski +-- This file is a part of the computer game Allure of the Stars +-- and is released under the terms of the GNU Affero General Public License. +-- For license and copyright information, see the file LICENSE. +-- +-- | Monsters and heroes for Allure of the Stars. +module Content.ActorKind ( cdefs ) where -import Color -import qualified Content.Content -import qualified Geometry -import qualified Random +import Game.LambdaHack.Color +import qualified Game.LambdaHack.Content as Content +import Game.LambdaHack.Content.ActorKind +import Game.LambdaHack.Random --- | Monster properties that are changing rarely and permanently. -data ActorKind = ActorKind - { ahp :: !Random.RollDice -- ^ encodes initial and maximal hp - , aspeed :: !Geometry.Time -- ^ natural speed - , asymbol :: !Char -- ^ map symbol - , acolor :: !Color -- ^ map color - , aname :: !String -- ^ name - , asight :: !Bool -- ^ can it see? - , asmell :: !Bool -- ^ can it smell? - , aiq :: !Int -- ^ intelligence - , aregen :: !Int -- ^ regeneration interval - , afreq :: !Int -- ^ dungeon frequency +cdefs :: Content.CDefs ActorKind +cdefs = Content.CDefs + { getSymbol = asymbol + , getName = aname + , getFreq = afreq + , validate = avalidate + , content = + [hero, eye, fastEye, nose] } - deriving (Show, Eq, Ord) - -instance Content.Content.Content ActorKind where - getFreq = afreq - content = - [hero, eye, fastEye, nose] - -hero, eye, fastEye, nose :: ActorKind +hero, eye, fastEye, nose :: ActorKind hero = ActorKind - { ahp = (50, 1) - , aspeed = 10 - , asymbol = '@' + { asymbol = '@' , aname = "hero" + , afreq = [("hero", 1)] -- Does not appear randomly in the dungeon. , acolor = BrWhite -- Heroes white, monsters colorful. + , ahp = RollDice 60 1 + , aspeed = 10 , asight = True , asmell = False - , aiq = 13 -- Can see secret doors, when he is under alien control. - , aregen = 1500 - , afreq = 0 -- Does not appear randomly in the dungeon. - + , aiq = 13 -- Can see hidden doors, when he is under alien control. + , aregen = 5000 } eye = ActorKind - { ahp = (1, 12) -- falls in 1--4 unarmed rounds + { asymbol = 'r' + , aname = "deranged household robot" + , afreq = [("monster", 60), ("summon", 50)] + , acolor = BrYellow + , ahp = RollDice 3 4 , aspeed = 10 - , asymbol = 'e' - , acolor = BrRed - , aname = "the reducible eye" , asight = True , asmell = False , aiq = 8 - , aregen = 1500 - , afreq = 6 + , aregen = 1000 } fastEye = ActorKind - { ahp = (1, 6) -- falls in 1--2 unarmed rounds - , aspeed = 4 - , asymbol = 'e' - , acolor = BrBlue - , aname = "the super-fast eye" + { asymbol = 'm' + , aname = "deformed monkey" + , afreq = [("monster", 15)] + , acolor = BrMagenta + , ahp = RollDice 1 4 + , aspeed = 5 , asight = True , asmell = False , aiq = 12 - , aregen = 1500 - , afreq = 1 + , aregen = 50 -- Regenerates fast (at max HP most of the time!). } nose = ActorKind - { ahp = (6, 2) -- 2--5 and in 1 round of the strongest sword - , aspeed = 11 - , asymbol = 'n' + { asymbol = 'h' + , aname = "tentacled horror" + , afreq = [("monster", 20), ("summon", 100)] , acolor = Green - , aname = "the point-free nose" + , ahp = RollDice 7 2 + , aspeed = 11 , asight = False , asmell = True , aiq = 0 - , aregen = 1500 - , afreq = 2 + , aregen = 1000 } diff --git a/src/Content/CaveKind.hs b/src/Content/CaveKind.hs --- a/src/Content/CaveKind.hs +++ b/src/Content/CaveKind.hs @@ -1,73 +1,87 @@ -module Content.CaveKind (CaveKind(..), CaveLayout(..)) where +-- Copyright (c) 2008--2011 Andres Loeh, 2010--2012 Mikolaj Konarski +-- This file is a part of the computer game Allure of the Stars +-- and is released under the terms of the GNU Affero General Public License. +-- For license and copyright information, see the file LICENSE. +-- +-- | Cave layouts for Allure of the Stars. +module Content.CaveKind ( cdefs ) where import Data.Ratio -import qualified Content.Content -import Geometry -import Random - -instance Content.Content.Content CaveKind where - getFreq = cfreq - content = - [rogue, empty, noise, largeNoise] - -rogue, empty, noise, largeNoise:: CaveKind +import qualified Game.LambdaHack.Content as Content +import Game.LambdaHack.Misc +import Game.LambdaHack.Random as Random +import Game.LambdaHack.Content.CaveKind -data CaveKind = CaveKind - { cxsize :: X - , cysize :: Y - , levelGrid :: Rnd (X, Y) - , minRoomSize :: Rnd (X ,Y) - , darkRoomChance :: Int -> Rnd Bool -- TODO: use RollQuad instead, etc. - , border :: Int -- must be at least 2! - , extraConnects :: (X, Y) -> Int - -- relative to grid (in fact a range, because of duplicate connects) - , noRooms :: (X, Y) -> Rnd Int - -- range, relative to grid - , minStairsDistance :: Int - , doorChance :: Rnd Bool - , doorOpenChance :: Rnd Bool - , doorSecretChance :: Rnd Bool - , csecretStrength :: RollDice - , citemNum :: RollDice - , clayout :: CaveLayout - , cfreq :: Int +cdefs :: Content.CDefs CaveKind +cdefs = Content.CDefs + { getSymbol = csymbol + , getName = cname + , getFreq = cfreq + , validate = cvalidate + , content = + [rogue, arena, empty, noise] } - --- TODO: express those using many fine-graned parameters instead -data CaveLayout = CaveRogue | CaveEmpty | CaveNoise deriving Eq +rogue, arena, empty, noise :: CaveKind rogue = CaveKind - { cxsize = fst normalLevelBound + 1 - , cysize = snd normalLevelBound + 1 - , levelGrid = do - x <- Random.randomR (3, 5) - y <- Random.randomR (2, 4) - return (x, y) - , minRoomSize = return (2, 2) - , darkRoomChance = \ d -> Random.chance $ 1%((22 - (2 * fromIntegral d)) `max` 2) - , border = 2 - , extraConnects = \ (x, y) -> (x * y) `div` 3 - , noRooms = \ (x, y) -> Random.randomR (0, (x * y) `div` 3) - , minStairsDistance = 30 - , doorChance = Random.chance $ 2%3 - , doorOpenChance = Random.chance $ 1%10 - , doorSecretChance = Random.chance $ 1%4 - , csecretStrength = (7, 2) - , citemNum = (5, 2) - , clayout = CaveRogue - , cfreq = 80 + { csymbol = '$' + , cname = "Storage area" + , cfreq = [("dng", 100), ("caveRogue", 1)] + , cxsize = fst normalLevelBound + 1 + , cysize = snd normalLevelBound + 1 + , cgrid = RollDiceXY (RollDice 2 3, RollDice 2 2) + , cminPlaceSize = RollDiceXY (RollDice 2 2, RollDice 2 1) + , cdarkChance = (RollDice 1 54, RollDice 0 0) + , cauxConnects = 1%3 + , cvoidChance = 1%4 + , cnonVoidMin = 4 + , cminStairDist = 30 + , cdoorChance = 1%2 + , copenChance = 1%10 + , chiddenChance = 1%5 + , citemNum = RollDice 5 2 + , cdefTile = "fillerWall" + , ccorTile = "darkCorridor" } +arena = rogue + { csymbol = 'A' + , cname = "Recreational deck" + , cfreq = [("dng", 100), ("caveArena", 1)] + , cgrid = RollDiceXY (RollDice 2 2, RollDice 2 2) + , cminPlaceSize = RollDiceXY (RollDice 3 2, RollDice 2 1) + , cdarkChance = (RollDice 1 80, RollDice 1 60) + , cvoidChance = 1%3 + , cnonVoidMin = 2 + , citemNum = RollDice 3 2 -- few rooms + , cdefTile = "floorArenaLit" + , ccorTile = "path" + } empty = rogue - { clayout = CaveEmpty - , cfreq = 20 + { csymbol = '.' + , cname = "Construction site" + , cfreq = [("dng", 100), ("caveEmpty", 1)] + , cgrid = RollDiceXY (RollDice 2 2, RollDice 1 2) + , cminPlaceSize = RollDiceXY (RollDice 4 3, RollDice 4 1) + , cdarkChance = (RollDice 1 80, RollDice 1 80) + , cauxConnects = 1 + , cvoidChance = 3%4 + , cnonVoidMin = 1 + , cminStairDist = 50 + , citemNum = RollDice 6 2 -- whole floor strewn with treasure + , cdefTile = "floorRoomLit" + , ccorTile = "floorRoomLit" } noise = rogue - { clayout = CaveNoise - , cfreq = 0 -- stairs may be blocked, so only for the last level - } -largeNoise = noise - { cxsize = 231 - , cysize = 77 - , cfreq = 0 -- experimental + { csymbol = '!' + , cname = "Machine rooms" + , cfreq = [("dng", 100), ("caveNoise", 1)] + , cgrid = RollDiceXY (RollDice 2 2, RollDice 1 2) + , cminPlaceSize = RollDiceXY (RollDice 4 2, RollDice 4 1) + , cdarkChance = (RollDice 1 80, RollDice 1 40) + , cvoidChance = 0 + , cnonVoidMin = 0 + , citemNum = RollDice 3 2 -- few rooms + , cdefTile = "noiseSet" + , ccorTile = "path" } diff --git a/src/Content/Content.hs b/src/Content/Content.hs deleted file mode 100644 --- a/src/Content/Content.hs +++ /dev/null @@ -1,16 +0,0 @@ -module Content.Content (Content(..)) where - -import qualified Data.List as L -import qualified Data.IntMap as IM -import qualified Data.Word as Word - -class Content a where - getFreq :: a -> Int - - content :: [a] - - kindAssocs :: [(Word.Word8, a)] - kindAssocs = L.zip [0..] content - - kindMap :: IM.IntMap a - kindMap = IM.fromDistinctAscList $ L.zip [0..] content diff --git a/src/Content/ItemKind.hs b/src/Content/ItemKind.hs --- a/src/Content/ItemKind.hs +++ b/src/Content/ItemKind.hs @@ -1,153 +1,202 @@ -module Content.ItemKind (ItemKind(..)) where +-- Copyright (c) 2008--2011 Andres Loeh, 2010--2012 Mikolaj Konarski +-- This file is a part of the computer game Allure of the Stars +-- and is released under the terms of the GNU Affero General Public License. +-- For license and copyright information, see the file LICENSE. +-- +-- | Weapons and treasure for Allure of the Stars. +module Content.ItemKind ( cdefs ) where -import Color -import qualified Content.Content -import Effect -import Flavour -import Random +import Game.LambdaHack.Color +import qualified Game.LambdaHack.Content as Content +import Game.LambdaHack.Effect +import Game.LambdaHack.Flavour +import Game.LambdaHack.Random +import Game.LambdaHack.Content.ItemKind --- TODO: jpower is out of place here. It doesn't make sense for all items, --- and will mean different things for different items. Perhaps it should --- be part of the Effect, but then we have to be careful to distinguish --- parts of the Effect that are rolled on item creation and those rolled --- at each use (e.g., sword magical +damage vs. sword damage dice). --- Another thing to keep in minds is that jpower will heavily determine --- the value of the item for shops, treasure chests, artifact set rebalancing, --- etc., so if we make jpower complex, the value computation gets complex too. -data ItemKind = ItemKind - { isymbol :: !Char -- ^ map symbol - , iflavour :: ![Flavour] -- ^ possible flavours - , iname :: !String -- ^ group name - , ieffect :: !Effect -- ^ the effect when activated - , icount :: !RollQuad -- ^ created in that quantify - , ifreq :: !Int -- ^ created that often - , ipower :: !RollQuad -- ^ created with that power +cdefs :: Content.CDefs ItemKind +cdefs = Content.CDefs + { getSymbol = isymbol + , getName = iname + , getFreq = ifreq + , validate = ivalidate + , content = + [necklace, dart, gem1, gem2, gem3, gold, javelin, potion1, potion2, potion3, ring, scroll1, scroll2, scroll3, sword, wand, fist, foot, tentacle, weight] } - deriving (Show, Eq, Ord) - -instance Content.Content.Content ItemKind where - getFreq = ifreq - content = - [amulet, dart, gem1, gem2, gem3, gem4, gold, potion1, potion2, potion3, ring, scroll1, scroll2, sword, fist, wand] - -amulet, dart, gem1, gem2, gem3, gem4, gold, potion1, potion2, potion3, ring, scroll1, scroll2, sword, fist, wand :: ItemKind +necklace, dart, gem1, gem2, gem3, gold, javelin, potion1, potion2, potion3, ring, scroll1, scroll2, scroll3, sword, wand, fist, foot, tentacle, weight :: ItemKind gem, potion, scroll :: ItemKind -- generic templates --- rollQuad (a, b, x, y) = a * roll b + (lvl * x * roll y) / 10 +-- rollDeep (aDb, xDy) = rollDice aDb + lvl * rollDice xDy / depth -amulet = ItemKind +necklace = ItemKind { isymbol = '"' - , iflavour = [(BrGreen, True)] - , iname = "amulet" - , ieffect = Regneration - , icount = intToQuad 1 - , ifreq = 10 - , ipower = (2, 1, 2, 2) + , iname = "necklace" + , ifreq = [("dng", 6)] + , iflavour = zipFancy [BrGreen] + , ieffect = Regeneration + , icount = intToDeep 1 + , ipower = (RollDice 2 3, RollDice 1 10) + , iverbApply = "tear down" + , iverbProject = "throw" } dart = ItemKind - { isymbol = ')' - , iflavour = [(Yellow, False)] - , iname = "dart" - , ieffect = Wound (1, 1) - , icount = (3, 3, 0, 0) - , ifreq = 30 - , ipower = intToQuad 0 + { isymbol = '|' + , iname = "billiard ball" + , ifreq = [("dng", 30)] + , iflavour = zipPlain [Cyan] + , ieffect = Wound (RollDice 1 1) + , icount = (RollDice 3 3, RollDice 0 0) + , ipower = intToDeep 0 + , iverbApply = "snap" + , iverbProject = "throw" } gem = ItemKind { isymbol = '*' + , iname = "precious gem" + , ifreq = [("dng", 20)] -- x3, but rare on shallow levels , iflavour = zipPlain brightCol -- natural, so not fancy - , iname = "gem" , ieffect = NoEffect - , icount = intToQuad 0 - , ifreq = 20 -- x4, but rare on shallow levels - , ipower = intToQuad 0 + , icount = intToDeep 0 + , ipower = intToDeep 0 + , iverbApply = "crush" + , iverbProject = "throw" } gem1 = gem - { icount = (1, 1, 0, 0) -- appears on lvl 1 + { icount = (RollDice 0 0, RollDice 1 1) -- appears on max depth } gem2 = gem - { icount = (0, 0, 2, 1) -- appears on lvl 5, doubled on lvl 10 + { icount = (RollDice 0 0, RollDice 1 2) -- appears halfway, doubled on max } gem3 = gem - { icount = (0, 0, 1, 1) -- appears on lvl 10 - } -gem4 = gem - { icount = (0, 0, 1, 1) -- appears on lvl 10 + { icount = (RollDice 0 0, RollDice 1 3) } gold = ItemKind { isymbol = '$' - , iflavour = [(BrYellow, False)] - , iname = "gold piece" + , iname = "gold coin" + , ifreq = [("dng", 80)] + , iflavour = zipPlain [BrYellow] , ieffect = NoEffect - , icount = (0, 0, 10, 10) - , ifreq = 80 - , ipower = intToQuad 0 + , icount = (RollDice 0 0, RollDice 10 10) + , ipower = intToDeep 0 + , iverbApply = "grind" + , iverbProject = "throw" } +javelin = ItemKind + { isymbol = '|' + , iname = "kitchen knife" + , ifreq = [("dng", 30)] + , iflavour = zipPlain [Brown] + , ieffect = Wound (RollDice 1 2) + , icount = (RollDice 0 0, RollDice 2 2) + , ipower = (RollDice 1 1, RollDice 2 2) + , iverbApply = "break up" + , iverbProject = "throw" + } potion = ItemKind { isymbol = '!' + , iname = "concoction" + , ifreq = [("dng", 15)] , iflavour = zipFancy stdCol - , iname = "potion" , ieffect = NoEffect - , icount = intToQuad 1 - , ifreq = 10 - , ipower = intToQuad 0 + , icount = intToDeep 1 + , ipower = intToDeep 0 + , iverbApply = "gulp down" + , iverbProject = "lob" } potion1 = potion - { ieffect = ApplyPerfume + { ifreq = [("dng", 5)] + , ieffect = ApplyPerfume } potion2 = potion { ieffect = Heal - , ipower = (10, 1, 0, 0) + , ipower = (RollDice 5 1, RollDice 0 0) } potion3 = potion - { ieffect = Wound (0, 0) - , ipower = (10, 1, 0, 0) + { ifreq = [("dng", 5)] + , ieffect = Wound (RollDice 0 0) + , ipower = (RollDice 5 1, RollDice 0 0) } ring = ItemKind { isymbol = '=' - , iflavour = [(White, False)] , iname = "ring" + , ifreq = [("dng", 10)] + , iflavour = zipPlain [White] , ieffect = Searching - , icount = intToQuad 1 - , ifreq = 10 - , ipower = (1, 1, 2, 2) + , icount = intToDeep 1 + , ipower = (RollDice 1 6, RollDice 3 2) + , iverbApply = "squeeze down" + , iverbProject = "throw" } scroll = ItemKind { isymbol = '?' + , iname = "comm tablet" + , ifreq = [("dng", 6)] , iflavour = zipFancy darkCol -- arcane and old - , iname = "scroll" , ieffect = NoEffect - , icount = intToQuad 1 - , ifreq = 10 - , ipower = intToQuad 0 + , icount = intToDeep 1 + , ipower = intToDeep 0 + , iverbApply = "dial" + , iverbProject = "throw" } scroll1 = scroll { ieffect = SummonFriend - , ifreq = 20 } scroll2 = scroll - { ieffect = SummonEnemy + { ifreq = [("dng", 3)] + , ieffect = SummonEnemy } +scroll3 = scroll + { ieffect = Descend + } sword = ItemKind { isymbol = ')' - , iflavour = [(BrCyan, False)] - , iname = "sword" - , ieffect = Wound (3, 1) - , icount = intToQuad 1 - , ifreq = 60 - , ipower = (1, 2, 4, 2) - } -fist = sword - { iname = "fist" - , ifreq = 0 -- Does not appear randomly in the dungeon. + , iname = "sharpened pipe" + , ifreq = [("dng", 60)] + , iflavour = zipPlain [BrCyan] + , ieffect = Wound (RollDice 3 1) + , icount = intToDeep 1 + , ipower = (RollDice 1 2, RollDice 4 2) + , iverbApply = "hit" + , iverbProject = "heave" } wand = ItemKind { isymbol = '/' - , iflavour = [(BrRed, True)] - , iname = "wand" + , iname = "transmitter" + , ifreq = [("dng", 15)] + , iflavour = zipFancy [BrRed] , ieffect = Dominate - , icount = intToQuad 1 - , ifreq = 10 - , ipower = intToQuad 0 + , icount = intToDeep 1 + , ipower = intToDeep 0 + , iverbApply = "snap" + , iverbProject = "zap" + } +fist = sword + { isymbol = '@' + , iname = "fist" + , ifreq = [("unarmed", 100)] + , iverbApply = "punch" + , iverbProject = "ERROR, please report: iverbProject fist" + } +foot = sword + { isymbol = '@' + , iname = "foot" + , ifreq = [("unarmed", 50)] + , iverbApply = "kick" + , iverbProject = "ERROR, please report: iverbProject foot" + } +tentacle = sword + { isymbol = 'S' + , iname = "tentacle" + , ifreq = [("monstrous", 100)] + , iverbApply = "hit" + , iverbProject = "ERROR, please report: iverbProject tentacle" + } +weight = sword + { isymbol = '@' + , iname = "power jump" + , ifreq = [("weight", 100)] + , ieffect = Wound (RollDice 99 99) + , ipower = (RollDice 1 99, RollDice 0 0) + , iverbApply = "squash" + , iverbProject = "ERROR, please report: iverbProject weight" } diff --git a/src/Content/PlaceKind.hs b/src/Content/PlaceKind.hs new file mode 100644 --- /dev/null +++ b/src/Content/PlaceKind.hs @@ -0,0 +1,148 @@ +-- Copyright (c) 2008--2011 Andres Loeh, 2010--2012 Mikolaj Konarski +-- This file is a part of the computer game Allure of the Stars +-- and is released under the terms of the GNU Affero General Public License. +-- For license and copyright information, see the file LICENSE. +-- +-- | Rooms, halls and passages for Allure of the Stars. +module Content.PlaceKind ( cdefs ) where + +import qualified Game.LambdaHack.Content as Content +import Game.LambdaHack.Content.PlaceKind + +cdefs :: Content.CDefs PlaceKind +cdefs = Content.CDefs + { getSymbol = psymbol + , getName = pname + , getFreq = pfreq + , validate = pvalidate + , content = + [rect, oval, ovalFloor, ovalSquare, colonnade, colonnadeWide, maze, maze2, maze3, mazeBig, mazeBig2, mazeBig3, cells] + } +rect, oval, ovalFloor, ovalSquare, colonnade, colonnadeWide, maze, maze2, maze3, mazeBig, mazeBig2, mazeBig3, cells :: PlaceKind + +rect = PlaceKind -- Valid for any nonempty area, hence low frequency. + { psymbol = 'r' + , pname = "room" + , pfreq = [("rogue", 100)] + , pcover = CStretch + , pfence = FWall + , ptopLeft = ["."] + } +oval = PlaceKind + { psymbol = 'o' + , pname = "oval room" + , pfreq = [("rogue", 1000)] + , pcover = CStretch + , pfence = FWall + , ptopLeft = [ "####.." + , "##...." + , "#....." + , "#....." + , "......" + , "......" + ] + } +ovalFloor = oval -- Without outer solid fence, visible from outside. + { pfreq = [("rogue", 10000)] + , pfence = FFloor + , ptopLeft = [ "XXXX+#" + , "XX###." + , "X##..." + , "X#...." + , "+#...." + , "#....." + ] + } +ovalSquare = ovalFloor + { ptopLeft = [ "X###+" + , "##..." + , "#...." + , "#...." + , "+...." + ] + } +colonnade = PlaceKind + { psymbol = 'c' + , pname = "colonnade" + , pfreq = [("rogue", 1000)] + , pcover = CAlternate + , pfence = FFloor + , ptopLeft = [ ".#" + , "#." + ] + } +colonnadeWide = colonnade + { pfreq = [("rogue", 50)] + , pfence = FWall + , ptopLeft = [ ".." + , ".#" + ] + } +maze = PlaceKind + { psymbol = 'm' + , pname = "maze" + , pfreq = [("rogue", 20)] + , pcover = CStretch + , pfence = FNone + , ptopLeft = [ "#.#.##" + , "##.#.." + , "#.##.#" + , "#.#.#." + ] + } +maze2 = maze + { ptopLeft = [ "###.##" + , ".###.." + , "..#..#" + , ".#..#." + ] + } +maze3 = maze + { ptopLeft = [ "###.##" + , ".##.#." + , "..##.#" + , ".#..#." + ] + } +mazeBig = maze + { pfreq = [("rogue", 1000)] + , ptopLeft = [ "#.#.##" + , ".#.#.." + , "#.#.##" + , ".#.#.." + , "#.#..#" + , "#.#.#." + ] + } +mazeBig2 = mazeBig + { ptopLeft = [ "##..##" + , "#.##.." + , ".#.###" + , ".##.#." + , "#.##.#" + , "#.#.#." + ] + } +mazeBig3 = mazeBig + { ptopLeft = [ "##..##" + , "#.###." + , ".#...#" + , ".#.##." + , "##.#.#" + , "#.#.#." + ] + } +cells = PlaceKind + { psymbol = '#' + , pname = "cells" + , pfreq = [("rogue", 30)] + , pcover = CReflect + , pfence = FWall + , ptopLeft = [ "..#" + , "..#" + , "##." + ] + } +-- TODO: obtain all the reet as places nested within places. +-- 3 places are enough, with 1 or 2 tiles between places, +-- on all sides, only vertical, only horizontal, diff --git a/src/Content/RuleKind.hs b/src/Content/RuleKind.hs new file mode 100644 --- /dev/null +++ b/src/Content/RuleKind.hs @@ -0,0 +1,40 @@ +-- Copyright (c) 2008--2011 Andres Loeh, 2010--2012 Mikolaj Konarski +-- This file is a part of the computer game Allure of the Stars +-- and is released under the terms of the GNU Affero General Public License. +-- For license and copyright information, see the file LICENSE. +-- +-- | Game rules and assorted data for Allure of the Stars. +module Content.RuleKind ( cdefs ) where + +-- Cabal +import qualified Paths_Allure as Self (getDataFileName, version) + +import Game.LambdaHack.Content.RuleKind +import Game.LambdaHack.Content.TileKind +import qualified Game.LambdaHack.Feature as F +import qualified Game.LambdaHack.Content as Content + +cdefs :: Content.CDefs RuleKind +cdefs = Content.CDefs + { getSymbol = rsymbol + , getName = rname + , getFreq = rfreq + , validate = ruvalidate + , content = + [standard] + } +standard :: RuleKind + +standard = RuleKind + { rsymbol = 's' + , rname = "standard Allure of the Stars ruleset" + , rfreq = [("standard", 100)] + -- Check whether one location is accessible from another. + -- Precondition: the two locations are next to each other. + -- TODO: in the future check flying for chasms, swimming for water, etc. + , raccessible = \ _lxsize _sloc _src _tloc tgt -> + F.Walkable `elem` tfeature tgt + , rtitle = "Allure of the Stars" + , rpathsDataFile = Self.getDataFileName + , rpathsVersion = Self.version + } diff --git a/src/Content/TileKind.hs b/src/Content/TileKind.hs --- a/src/Content/TileKind.hs +++ b/src/Content/TileKind.hs @@ -1,110 +1,128 @@ -module Content.TileKind (TileKind(..)) where +-- Copyright (c) 2008--2011 Andres Loeh, 2010--2012 Mikolaj Konarski +-- This file is a part of the computer game Allure of the Stars +-- and is released under the terms of the GNU Affero General Public License. +-- For license and copyright information, see the file LICENSE. +-- +-- | Terrain tiles for Allure of the Stars. +module Content.TileKind ( cdefs ) where -import Color -import qualified Content.Content -import qualified Effect -import Feature +import Game.LambdaHack.Color +import qualified Game.LambdaHack.Content as Content +import qualified Game.LambdaHack.Effect as Effect +import Game.LambdaHack.Feature +import Game.LambdaHack.Content.TileKind +import Game.LambdaHack.Random -data TileKind = TileKind - { tsymbol :: !Char -- ^ map symbol - , tname :: !String -- ^ name - , tcolor :: !Color -- ^ map color - , tcolor2 :: !Color -- ^ map color when not in FOV - , tfreq :: !Int -- ^ created that often (within a group?) - , tfeature :: ![Feature] -- ^ properties +cdefs :: Content.CDefs TileKind +cdefs = Content.CDefs + { getSymbol = tsymbol + , getName = tname + , getFreq = tfreq + , validate = tvalidate + , content = + [wall, doorHidden, doorClosed, doorOpen, pillar, stairsUp, stairsDown, unknown, floorCorridorLit, floorCorridorDark, floorRoomLit, floorRoomDark, floorRed, floorBlue, floorGreen] } - deriving (Show, Eq, Ord) - -instance Content.Content.Content TileKind where - getFreq = tfreq - content = - [wall, doorOpen, doorClosed, doorSecret, opening, floorLight, floorDark, stairsUp, stairsDown, unknown] - -wall, doorOpen, doorClosed, doorSecret, opening, floorLight, floorDark, stairsUp, stairsDown, unknown :: TileKind +wall, doorHidden, doorClosed, doorOpen, pillar, stairsUp, stairsDown, unknown, floorCorridorLit, floorCorridorDark, floorRoomLit, floorRoomDark, floorRed, floorBlue, floorGreen :: TileKind wall = TileKind { tsymbol = '#' - , tname = "A wall." + , tname = "wall" + , tfreq = [ ("litLegend", 100), ("darkLegend", 100) + , ("fillerWall", 1), ("noiseSet", 55) ] , tcolor = BrWhite , tcolor2 = defFG - , tfreq = 100 , tfeature = [] } - -doorOpen = TileKind - { tsymbol = '\'' - , tname = "An open door." - , tcolor = Yellow - , tcolor2 = BrBlack - , tfreq = 100 - , tfeature = [Walkable, Clear, Exit{-TODO:, Lit-}, Change '+', Closable] +doorHidden = wall + { tfreq = [("hidden", 100)] + , tfeature = [Hidden, Secret (RollDice 7 2), ChangeTo "closed door"] } - doorClosed = TileKind { tsymbol = '+' - , tname = "A closed door." - , tcolor = Yellow + , tname = "closed door" + , tfreq = [("litLegend", 100), ("darkLegend", 100), ("closed door", 1)] + , tcolor = Brown , tcolor2 = BrBlack - , tfreq = 100 - , tfeature = [Exit, Change '\'', Openable] - } - -doorSecret = wall - { tfeature = [Hidden, Change '+', Secret (7, 2)] + , tfeature = [Exit, Openable, ChangeTo "open door"] } - -opening = TileKind - { tsymbol = '.' - , tname = "An opening." - , tcolor = BrWhite - , tcolor2 = defFG - , tfreq = 100 - , tfeature = [Walkable, Clear, Exit{-TODO: , Lit-}] +doorOpen = TileKind + { tsymbol = '\'' + , tname = "open door" + , tfreq = [("litLegend", 100), ("darkLegend", 100), ("open door", 1)] + , tcolor = Brown + , tcolor2 = BrBlack + , tfeature = [Walkable, Clear, Exit, Closable, ChangeTo "closed door"] } - -floorLight = TileKind - { tsymbol = '.' - , tname = "Floor." +pillar = TileKind + { tsymbol = 'O' + , tname = "pillar" + , tfreq = [("litLegend", 100), ("darkLegend", 100)] , tcolor = BrWhite , tcolor2 = defFG - , tfreq = 100 - , tfeature = [Walkable, Clear, Lit] - } - -floorDark = TileKind - { tsymbol = '.' - , tname = "Floor." - , tcolor = BrYellow - , tcolor2 = BrBlack - , tfreq = 100 - , tfeature = [Walkable, Clear] + , tfeature = [] } - stairsUp = TileKind { tsymbol = '<' - , tname = "A staircase up." + , tname = "staircase up" + , tfreq = [("litLegend", 100), ("darkLegend", 100)] , tcolor = BrWhite , tcolor2 = defFG - , tfreq = 100 - , tfeature = [Walkable, Clear, Exit, Lit, - Climbable, Cause Effect.Teleport] + , tfeature = [Walkable, Clear, Lit, Exit, Ascendable, Cause Effect.Ascend] } - stairsDown = TileKind { tsymbol = '>' - , tname = "A staircase down." + , tname = "staircase down" + , tfreq = [("litLegend", 100), ("darkLegend", 100)] , tcolor = BrWhite , tcolor2 = defFG - , tfreq = 100 - , tfeature = [Walkable, Clear, Exit, Lit, - Descendable, Cause Effect.Teleport] + , tfeature = [Walkable, Clear, Lit, Exit, Descendable, Cause Effect.Descend] } - unknown = TileKind { tsymbol = ' ' - , tname = "" + , tname = "unknown space" + , tfreq = [("unknown space", 1)] + , tcolor = defFG + , tcolor2 = BrWhite + , tfeature = [] + } +floorCorridorLit = TileKind + { tsymbol = '.' + , tname = "floor" + , tfreq = [("noiseSet", 100), ("floorArenaLit", 1)] , tcolor = BrWhite , tcolor2 = defFG - , tfreq = 100 - , tfeature = [] + , tfeature = [Walkable, Clear, Lit] + } +floorCorridorDark = floorCorridorLit + { tfreq = [("darkCorridor", 1)] + , tcolor = BrYellow + , tcolor2 = BrBlack + , tfeature = [Walkable, Clear] + } +floorRoomLit = floorCorridorLit + { tfreq = [("litLegend", 100), ("floorRoomLit", 1)] + , tfeature = Boring : tfeature floorCorridorLit + } +floorRoomDark = floorCorridorDark + { tfreq = [("darkLegend", 100)] + , tfeature = Boring : tfeature floorCorridorDark + } +floorRed = floorCorridorLit + { tname = "emergency walkway" + , tfreq = [("path", 20)] + , tcolor = BrRed + , tcolor2 = Red + , tfeature = Path : tfeature floorCorridorLit + } +floorBlue = floorRed + { tname = "transport route" + , tfreq = [("path", 100)] + , tcolor = BrBlue + , tcolor2 = Blue + } +floorGreen = floorRed + { tname = "greenery path" + , tfreq = [("path", 100)] + , tcolor = BrGreen + , tcolor2 = Green } diff --git a/src/Dir.hs b/src/Dir.hs deleted file mode 100644 --- a/src/Dir.hs +++ /dev/null @@ -1,77 +0,0 @@ -module Dir - ( Dir, dirDistSq, diagonal, neg, moves, shift, towards ) where - -import Data.Binary - -import Geometry -import Loc -import Utils.Assert - --- Vectors of length 1 (in our metric), that is, geographical directions. --- Implemented as an offset in the linear framebuffer indexed by Loc. --- A newtype to prevent mixing up with Loc itself. --- Level X size has to be > 1 for the @moves@ vectors to make sense. -newtype Dir = Dir Int deriving (Show, Eq) - -instance Binary Dir where - put (Dir dir) = put dir - get = fmap Dir get - -toDir :: X -> (X, Y) -> Dir -toDir lxsize (x, y) = - assert (lxsize > 1 && lenXY (x, y) == 1 `blame` (lxsize, (x, y))) $ - Dir $ x + y * lxsize - -fromDir :: X -> Dir -> (X, Y) -fromDir lxsize (Dir dir) = - assert (lenXY res == 1 && fst res + snd res * lxsize == dir - `blame` (lxsize, dir, res)) $ - res - where - (x, y) = (dir `mod` lxsize, dir `div` lxsize) - -- Pick the vector's canonical form of length 1: - res = if x > 1 - then (x - lxsize, y + 1) - else (x, y) - --- | Squared euclidean distance between two directions. -dirDistSq :: X -> Dir -> Dir -> Int -dirDistSq lxsize dir0 dir1 - | (x0, y0) <- fromDir lxsize dir0, (x1, y1) <- fromDir lxsize dir1 = - euclidLenSq ((y1 - y0), (x1 - x0)) - -diagonal :: X -> Dir -> Bool -diagonal lxsize dir | (x, y) <- fromDir lxsize dir = - x * y /= 0 - --- | Invert a direction (vector). -neg :: Dir -> Dir -neg (Dir dir) = Dir (-dir) - --- | Directions of all unit moves, clockwise, starting north-west. -moves :: X -> [Dir] -moves lxsize = map (toDir lxsize) movesXY - --- | Move one square in the given direction. --- Particularly simple in the linear representation. -shift :: Loc -> Dir -> Loc -shift loc (Dir dir) = loc + dir - --- | Given two distinct locations, determine the direction in which one should --- move from the first in order to get closer to the second. Does not --- pay attention to obstacles at all. -towards :: X -> Loc -> Loc -> Dir -towards lxsize loc0 loc1 - | (x0, y0) <- fromLoc lxsize loc0, (x1, y1) <- fromLoc lxsize loc1 = - assert (loc0 /= loc1 `blame` (loc0, loc1, x0, y0)) $ - let dx = x1 - x0 - dy = y1 - y0 - angle :: Double - angle = atan (fromIntegral dy / fromIntegral dx) / (pi / 2) - dxy | angle <= -0.75 = (0, -1) - | angle <= -0.25 = (1, -1) - | angle <= 0.25 = (1, 0) - | angle <= 0.75 = (1, 1) - | angle <= 1.25 = (0, 1) - | otherwise = assert `failure` (lxsize, loc0, loc1, (x0, y0), (x1, y1)) - in if dx >= 0 then toDir lxsize dxy else neg (toDir lxsize dxy) diff --git a/src/Display.hs b/src/Display.hs deleted file mode 100644 --- a/src/Display.hs +++ /dev/null @@ -1,221 +0,0 @@ -{-# LANGUAGE CPP #-} - -module Display where - --- wrapper for selected Display frontend - -#ifdef CURSES -import qualified Display.Curses as D -#elif VTY -import qualified Display.Vty as D -#elif STD -import qualified Display.Std as D -#else -import qualified Display.Gtk as D -#endif - --- Display routines that are independent of the selected display frontend. - -import qualified Data.Char as Char -import qualified Data.Set as S -import qualified Data.List as L -import qualified Data.Map as M -import qualified Data.IntMap as IM -import Control.Monad.IO.Class -import Data.Maybe - -import Message -import qualified Color -import State -import Geometry -import Loc -import Area -import Level -import Perception -import Actor -import ActorState -import Content.ActorKind -import Content.TileKind -import Item -import qualified Keys as K -import WorldLoc -import Random -import qualified Kind - --- Re-exported from the display frontend, with an extra slot for function --- for translating keys to a canonical form. -type InternalSession = D.Session -type Session = (InternalSession, M.Map K.Key K.Key) -display :: Area -> Session -> (Loc -> (Color.Attr, Char)) -> String -> String - -> IO () -display area = D.display area . fst -startup :: (InternalSession -> IO ()) -> IO () -startup = D.startup -shutdown :: Session -> IO () -shutdown = D.shutdown . fst -displayId :: String -displayId = D.displayId - --- | Next event translated to a canonical form. -nextCommand :: MonadIO m => Session -> m K.Key -nextCommand session = - do - e <- liftIO $ D.nextEvent (fst session) - return $ fromMaybe (K.canonMoveKey e) (M.lookup e (snd session)) - --- | Displays a message on a blank screen. Waits for confirmation. -displayBlankConfirm :: Session -> String -> IO Bool -displayBlankConfirm session txt = - let x = txt ++ more - doBlank = const (Color.defaultAttr, ' ') - (lx, ly) = normalLevelBound -- TODO: query terminal size instead - in do - display (0, 0, lx, ly) session doBlank x "" - getConfirm session - --- | Waits for a space or return or '?' or '*'. The last two act this way, --- to let keys that request information toggle display the information off. -getConfirm :: MonadIO m => Session -> m Bool -getConfirm session = - getOptionalConfirm return (const $ getConfirm session) session - -getOptionalConfirm :: MonadIO m => - (Bool -> m a) -> (K.Key -> m a) -> Session -> m a -getOptionalConfirm h k session = - do - e <- liftIO $ nextCommand session - case e of - K.Char ' ' -> h True - K.Char '?' -> h True - K.Char '*' -> h True - K.Return -> h True - K.Esc -> h False - _ -> k e - --- | A yes-no confirmation. -getYesNo :: MonadIO m => Session -> m Bool -getYesNo session = - do - e <- liftIO $ nextCommand session - case e of - K.Char 'y' -> return True - K.Char 'n' -> return False - K.Esc -> return False - _ -> getYesNo session - -splitOverlay :: Int -> String -> [[String]] -splitOverlay s xs = splitOverlay' (lines xs) - where - splitOverlay' ls - | length ls <= s = [ls] -- everything fits on one screen - | otherwise = let (pre,post) = splitAt (s - 1) ls - in (pre ++ [more]) : splitOverlay' post - --- | Returns a function that looks up the characters in the --- string by location. Takes the height of the display plus --- the string. Returns also the number of screens required --- to display all of the string. -stringByLocation :: Y -> String -> (Int, (X, Y) -> Maybe Char) -stringByLocation sy xs = - let - ls = splitOverlay sy xs - m = M.fromList (zip [0..] (L.map (M.fromList . zip [0..]) (concat ls))) - k = length ls - in - (k, \ (x, y) -> M.lookup y m >>= \ n -> M.lookup x n) - -data ColorMode = ColorFull | ColorBW - -displayLevel :: - ColorMode -> Session -> Perceptions -> State -> Message -> Maybe String - -> IO Bool -displayLevel dm session per - state@State{scursor, stime, sflavour, slid} msg moverlay = - let lvl@Level{lxsize = sx, lysize = sy, lsmell = smap} = slevel state - Actor{bkind, bhp, bloc, bitems} = getPlayerBody state - ActorKind{ahp} = Kind.getKind bkind - reachable = ptreachable per - visible = ptvisible per - overlay = fromMaybe "" moverlay - (ns, over) = stringByLocation sy overlay -- n overlay screens needed - sSml = ssensory state == Smell - sVis = case ssensory state of Vision _ -> True; _ -> False - sOmn = sdisplay state == Omniscient - lAt = if sOmn then at else rememberAt - liAt = if sOmn then iat else irememberAt - sVisBG = if sVis - then \ vis rea -> if vis - then Color.Blue - else if rea - then Color.Magenta - else Color.defBG - else \ _vis _rea -> Color.defBG - wealth = L.sum $ L.map itemPrice bitems - damage = case strongestItem bitems "sword" of - Just sw -> 3 + jpower sw - Nothing -> 3 - hs = levelHeroList state - ms = levelMonsterList state - dis n loc0 = - let tile = lvl `lAt` loc0 - items = lvl `liAt` loc0 - sm = smelltime $ IM.findWithDefault (SmellTime 0) loc0 smap - sml = (sm - stime) `div` 100 - viewActor loc Actor{bkind = bkind2, bsymbol} - | loc == bloc && slid == creturnLn scursor = - (symbol, Color.defBG) -- highlight player - | otherwise = (symbol, acolor) - where - ActorKind{asymbol, acolor} = Kind.getKind bkind2 - symbol = fromMaybe asymbol bsymbol - viewSmell :: Int -> Char - viewSmell k - | k > 9 = '*' - | k < 0 = '-' - | otherwise = Char.intToDigit k - rainbow loc = toEnum $ loc `rem` 14 + 1 - (char, fg0) = - case L.find (\ m -> loc0 == Actor.bloc m) (hs ++ ms) of - Just m | sOmn || vis -> viewActor loc0 m - _ | sSml && sml >= 0 -> (viewSmell sml, rainbow loc0) - | otherwise -> - case items of - [] -> - let u = Kind.getKind tile - in (tsymbol u, if vis then tcolor u else tcolor2 u) - i : _ -> - Item.viewItem (jkind i) sflavour - vis = S.member loc0 visible - rea = S.member loc0 reachable - bg0 = if ctargeting scursor && loc0 == clocation scursor - then Color.defFG -- highlight targeting cursor - else sVisBG vis rea -- FOV debug - reverseVideo = (snd Color.defaultAttr, fst Color.defaultAttr) - optVisually (fg, bg) = - if (fg == Color.defBG) || (bg == Color.defFG && fg == Color.defFG) - then reverseVideo - else (fg, bg) - a = case dm of - ColorBW -> Color.defaultAttr - ColorFull -> optVisually (fg0, bg0) - in case over (fromLoc sx loc0 `shiftXY` (0, sy * n)) of - Just c -> (Color.defaultAttr, c) - _ -> (a, char) - status = - take 30 (levelName slid ++ repeat ' ') ++ - take 10 ("T: " ++ show (stime `div` 10) ++ repeat ' ') ++ - take 10 ("$: " ++ show wealth ++ repeat ' ') ++ - take 10 ("Dmg: " ++ show damage ++ repeat ' ') ++ - take 20 ("HP: " ++ show bhp ++ - " (" ++ show (maxDice ahp) ++ ")" ++ repeat ' ') - disp n mesg = display (0, 0, sx - 1, sy - 1) session (dis n) mesg status - msgs = splitMsg sx msg - perf k [] = perfo k "" - perf k [xs] = perfo k xs - perf k (x:xs) = disp ns (x ++ more) >> getConfirm session >>= \ b -> - if b then perf k xs else return False - perfo k xs - | k < ns - 1 = disp k xs >> getConfirm session >>= \ b -> - if b then perfo (k+1) xs else return False - | otherwise = disp k xs >> return True - in perf 0 msgs diff --git a/src/Display/Curses.hs b/src/Display/Curses.hs deleted file mode 100644 --- a/src/Display/Curses.hs +++ /dev/null @@ -1,129 +0,0 @@ -module Display.Curses - (displayId, startup, shutdown, display, nextEvent, Session) where - -import qualified UI.HSCurses.Curses as C -import qualified UI.HSCurses.CursesHelper as C -import qualified Data.List as L -import qualified Data.Map as M -import Control.Monad - -import Area -import Loc -import qualified Keys as K (Key(..)) -import qualified Color - -displayId :: String -displayId = "curses" - -data Session = Session - { win :: C.Window - , styles :: M.Map (Color.Color, Color.Color) C.CursesStyle - } - -startup :: (Session -> IO ()) -> IO () -startup k = - do - C.start - C.cursSet C.CursorInvisible - let s = [ ((f, b), C.Style (toFColor f) (toBColor b)) - | f <- [minBound..maxBound], - -- No more color combinations possible: 16*4, 64 is max. - b <- Color.legalBG ] - nr <- C.colorPairs - when (nr < L.length s) $ - C.end >> - error ("Terminal has too few color pairs (" ++ show nr ++ "). Giving up.") - let (ks, vs) = unzip s - ws <- C.convertStyles vs - let styleMap = M.fromList (zip ks ws) - k (Session C.stdScr styleMap) - -shutdown :: Session -> IO () -shutdown _ = C.end - -display :: Area -> Session -> (Loc -> (Color.Attr, Char)) -> String -> String - -> IO () -display (x0, y0, x1, y1) (Session { win = w, styles = s }) f msg status = - do - -- let defaultStyle = C.defaultCursesStyle - -- Terminals with white background require this: - let defaultStyle = s M.! Color.defaultAttr - C.erase - C.setStyle defaultStyle - C.mvWAddStr w 0 0 (toWidth (x1 - x0 + 1) msg) -- TODO: BS as in vty - C.mvWAddStr w (y1+2) 0 (toWidth (x1 - x0 + 1) status) - sequence_ [ C.setStyle (M.findWithDefault defaultStyle a s) - >> C.mvWAddStr w (y + 1) x [c] - | x <- [x0..x1], y <- [y0..y1], - let (a, c) = f (toLoc (x1 + 1) (x, y)) ] - C.refresh - -toWidth :: Int -> String -> String -toWidth n x = take n (x ++ repeat ' ') - -keyTranslate :: C.Key -> K.Key -keyTranslate e = - case e of - C.KeyChar '\ESC' -> K.Esc - C.KeyExit -> K.Esc - C.KeyChar '\n' -> K.Return - C.KeyChar '\r' -> K.Return - C.KeyEnter -> K.Return - C.KeyChar '\t' -> K.Tab - C.KeyUp -> K.Up - C.KeyDown -> K.Down - C.KeyLeft -> K.Left - C.KeySLeft -> K.Left - C.KeyRight -> K.Right - C.KeySRight -> K.Right - C.KeyHome -> K.Home - C.KeyPPage -> K.PgUp - C.KeyEnd -> K.End - C.KeyNPage -> K.PgDn - C.KeyBeg -> K.Begin - C.KeyB2 -> K.Begin - C.KeyClear -> K.Begin - -- No KP_ keys; see https://github.com/skogsbaer/hscurses/issues/10 - -- Movement keys are more important than hero selection, so preferring them: - C.KeyChar c - | c `elem` ['1'..'9'] -> K.KP c - | otherwise -> K.Char c - _ -> K.Unknown (show e) - -nextEvent :: Session -> IO K.Key -nextEvent _session = - do - e <- C.getKey C.refresh - return (keyTranslate e) --- case keyTranslate e of --- Unknown _ -> nextEvent session --- k -> return k - -toFColor :: Color.Color -> C.ForegroundColor -toFColor Color.Black = C.BlackF -toFColor Color.Red = C.DarkRedF -toFColor Color.Green = C.DarkGreenF -toFColor Color.Yellow = 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.Yellow = 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 diff --git a/src/Display/Gtk.hs b/src/Display/Gtk.hs deleted file mode 100644 --- a/src/Display/Gtk.hs +++ /dev/null @@ -1,179 +0,0 @@ -module Display.Gtk - (displayId, startup, shutdown, display, nextEvent, Session) where - -import Control.Monad -import Control.Concurrent -import Graphics.UI.Gtk.Gdk.Events -- TODO: replace, deprecated -import Graphics.UI.Gtk -import qualified Data.List as L -import Data.IORef -import qualified Data.Map as M -import qualified Data.ByteString.Char8 as BS - -import Area -import Loc -import Geometry -import qualified Keys as K (Key(..), keyTranslate) -import qualified Color - -displayId :: String -displayId = "gtk" - -data Session = Session - { schan :: Chan String - , stags :: M.Map Color.Attr TextTag - , sview :: TextView - } - -startup :: (Session -> IO ()) -> IO () -startup k = - do - -- initGUI - unsafeInitGUIForThreadedRTS - w <- windowNew - - ttt <- textTagTableNew - -- text attributes - tts <- fmap M.fromList $ - mapM (\ ak -> do - tt <- textTagNew Nothing - textTagTableAdd ttt tt - doAttr tt ak - return (ak, tt)) - [ (f, b) | f <- [minBound..maxBound], b <- Color.legalBG ] - - -- text buffer - tb <- textBufferNew (Just ttt) - textBufferSetText tb (unlines (replicate 25 (replicate 80 ' '))) - - -- create text view - tv <- textViewNewWithBuffer tb - containerAdd w tv - textViewSetEditable tv False - textViewSetCursorVisible tv False - - -- font - f <- fontDescriptionNew - fontDescriptionSetFamily f "Monospace" - fontDescriptionSetSize f 12 - widgetModifyFont tv (Just f) - currentfont <- newIORef f - onButtonPress tv (\ e -> case e of - Button { Graphics.UI.Gtk.Gdk.Events.eventButton = RightButton } -> - do - fsd <- fontSelectionDialogNew "Choose font" - cf <- readIORef currentfont - fds <- fontDescriptionToString cf - fontSelectionDialogSetFontName fsd fds - fontSelectionDialogSetPreviewText fsd "+##@##-...|" - resp <- dialogRun fsd - when (resp == ResponseOk) $ - do - fn <- fontSelectionDialogGetFontName fsd - case fn of - Just fn' -> do - fd <- fontDescriptionFromString fn' - writeIORef currentfont fd - widgetModifyFont tv (Just fd) - Nothing -> return () - widgetDestroy fsd - return True - _ -> return False) - - let black = Color minBound minBound minBound -- Color.defBG == Color.Black - white = Color 0xC500 0xBC00 0xB800 -- Color.defFG == Color.White - widgetModifyBase tv StateNormal black - widgetModifyText tv StateNormal white - - ec <- newChan - forkIO $ k (Session ec tts tv) - - onKeyPress tv - (\ e -> do - writeChan ec (Graphics.UI.Gtk.Gdk.Events.eventKeyName e) - return True) - - onDestroy w mainQuit -- set quit handler - widgetShowAll w - yield - mainGUI - -shutdown :: Session -> IO () -shutdown _ = mainQuit - -display :: Area -> Session -> (Loc -> (Color.Attr, Char)) -> String -> String - -> IO () -display (x0, y0, x1, y1) session f msg status = - postGUIAsync $ do - tb <- textViewGetBuffer (sview session) - let fLine y = let (as, cs) = unzip [ f (toLoc (x1 + 1) (x, y)) - | x <- [x0..x1] ] - in ((y, as), BS.pack cs) - memo = L.map fLine [y0..y1] - attrs = L.map fst memo - chars = L.map snd memo - bs = [BS.pack msg, BS.pack "\n", BS.unlines chars, BS.pack status] - textBufferSetByteString tb (BS.concat bs) - mapM_ (setTo tb (stags session) x0) attrs - -setTo :: TextBuffer -> M.Map Color.Attr TextTag -> X -> (Y, [Color.Attr]) - -> IO () -setTo _ _ _ (_, []) = return () -setTo tb tts lx (ly, attr:attrs) = do - ib <- textBufferGetIterAtLineOffset tb (ly + 1) lx - ie <- textIterCopy ib - let setIter :: Color.Attr -> Int -> [Color.Attr] -> IO () - setIter previous repetitions [] = do - textIterForwardChars ie repetitions - when (previous /= Color.defaultAttr) $ - textBufferApplyTag tb (tts M.! previous) ib ie - setIter previous repetitions (a:as) - | a == previous = - setIter a (repetitions + 1) as - | otherwise = do - textIterForwardChars ie repetitions - when (previous /= Color.defaultAttr) $ - textBufferApplyTag tb (tts M.! previous) ib ie - textIterForwardChars ib repetitions - setIter a 1 as - setIter attr 1 attrs - --- | reads until a non-dead key encountered -readUndeadChan :: Chan String -> IO String -readUndeadChan ch = - do - x <- readChan ch - if dead x then readUndeadChan ch else return x - where - dead x = - case x of - "Shift_R" -> True - "Shift_L" -> True - "Control_L" -> True - "Control_R" -> True - "Super_L" -> True - "Super_R" -> True - "Menu" -> True - "Alt_L" -> True - "Alt_R" -> True - "ISO_Level2_Shift" -> True - "ISO_Level3_Shift" -> True - "ISO_Level2_Latch" -> True - "ISO_Level3_Latch" -> True - "Num_Lock" -> True - "Caps_Lock" -> True - _ -> False - -nextEvent :: Session -> IO K.Key -nextEvent session = - do - e <- readUndeadChan (schan session) - return (K.keyTranslate e) - -doAttr :: TextTag -> Color.Attr -> IO () -doAttr tt (fg, bg) - | (fg, bg) == Color.defaultAttr = return () - | fg == Color.defFG = set tt [textTagBackground := Color.colorToRGB bg] - | bg == Color.defBG = set tt [textTagForeground := Color.colorToRGB fg] - | otherwise = set tt [textTagForeground := Color.colorToRGB fg, - textTagBackground := Color.colorToRGB bg] diff --git a/src/Display/Vty.hs b/src/Display/Vty.hs deleted file mode 100644 --- a/src/Display/Vty.hs +++ /dev/null @@ -1,99 +0,0 @@ -module Display.Vty - (displayId, startup, shutdown, display, nextEvent, Session) where - -import Graphics.Vty -import qualified Data.List as L -import qualified Data.ByteString.Char8 as BS - -import Area -import Loc -import qualified Keys as K (Key(..)) -import qualified Color - -displayId :: String -displayId = "vty" - -type Session = Vty - -startup :: (Session -> IO ()) -> IO () -startup k = mkVty >>= k - -display :: Area -> Session -> (Loc -> (Color.Attr, Char)) -> String -> String - -> IO () -display (x0, y0, x1, y1) vty f msg status = - let img = (foldr (<->) empty_image . - L.map (foldr (<|>) empty_image . - L.map (\ (x, y) -> let (a, c) = f (toLoc (x1 + 1) (x, y)) - in char (setAttr a) c))) - [ [ (x, y) | x <- [x0..x1] ] | y <- [y0..y1] ] - in update vty (pic_for_image - (utf8_bytestring (setAttr Color.defaultAttr) - (BS.pack (toWidth (x1 - x0 + 1) msg)) <-> - img <-> - utf8_bytestring (setAttr Color.defaultAttr) - (BS.pack (toWidth (x1 - x0 + 1) status)))) - -toWidth :: Int -> String -> String -toWidth n x = take n (x ++ repeat ' ') - -keyTranslate :: Event -> K.Key -keyTranslate e = - case e of - EvKey KEsc [] -> K.Esc - EvKey KEnter [] -> K.Return - EvKey (KASCII '\t') [] -> K.Tab - EvKey KUp [] -> K.Up - EvKey KDown [] -> K.Down - EvKey KLeft [] -> K.Left - EvKey KRight [] -> K.Right - EvKey KHome [] -> K.Home - EvKey KPageUp [] -> K.PgUp - EvKey KEnd [] -> K.End - EvKey KPageDown [] -> K.PgDn - EvKey KBegin [] -> K.Begin - -- No KP_ keys in vty; see https://github.com/coreyoconnor/vty/issues/8 - -- For now, movement keys are more important than hero selection: - EvKey (KASCII c) [] - | c `elem` ['1'..'9'] -> K.KP c - | otherwise -> K.Char c - _ -> K.Unknown (show e) - -nextEvent :: Session -> IO K.Key -nextEvent session = - do - e <- next_event session - return (keyTranslate e) - --- A hack to get bright colors via the bold attribute. Depending on terminal --- settings this is needed or not and the characters really get bold or not. --- HSCurses does this by default, but in Vty you have to request the hack. -hack :: Color.Color -> Attr -> Attr -hack c a = if Color.isBright c then with_style a bold else a - -setAttr :: (Color.Color, Color.Color) -> Attr -setAttr (fg, bg) = --- This optimization breaks display for white background terminals: --- if (fg, bg) == Color.defaultAttr --- then def_attr --- else - hack fg $ hack bg $ - def_attr { attr_fore_color = SetTo (aToc fg), - attr_back_color = SetTo (aToc bg) } - -aToc :: Color.Color -> Color -aToc Color.Black = black -aToc Color.Red = red -aToc Color.Green = green -aToc Color.Yellow = yellow -aToc Color.Blue = blue -aToc Color.Magenta = magenta -aToc Color.Cyan = cyan -aToc Color.White = white -aToc Color.BrBlack = bright_black -aToc Color.BrRed = bright_red -aToc Color.BrGreen = bright_green -aToc Color.BrYellow = bright_yellow -aToc Color.BrBlue = bright_blue -aToc Color.BrMagenta = bright_magenta -aToc Color.BrCyan = bright_cyan -aToc Color.BrWhite = bright_white diff --git a/src/Dungeon.hs b/src/Dungeon.hs deleted file mode 100644 --- a/src/Dungeon.hs +++ /dev/null @@ -1,35 +0,0 @@ -module Dungeon (Dungeon, fromList, currentFirst, adjust, (!)) where - -import Data.Binary -import qualified Data.Map as M -import qualified Data.List as L - -import Level -import WorldLoc - --- | The complete dungeon is a map from level names to levels. --- We usually store all but the current level in this data structure. -newtype Dungeon = Dungeon{dungeonLevelMap :: M.Map LevelId Level} - deriving Show - -instance Binary Dungeon where - put dng = put (M.assocs (dungeonLevelMap dng)) - get = fmap fromList get - --- | Create a dungeon from a list of levels. -fromList :: [(LevelId, Level)] -> Dungeon -fromList = Dungeon . M.fromList - --- | Association list corresponding to the dungeon. --- Starts at the supplied level id (usually the current level) --- to try to speed up the searches and keep the dungeon lazy. -currentFirst :: LevelId -> Dungeon -> [(LevelId, Level)] -currentFirst slevel (Dungeon m) = - (slevel, m M.! slevel) - : L.filter ((/= slevel) . fst) (M.assocs m) - -adjust :: (Level -> Level) -> LevelId -> Dungeon -> Dungeon -adjust f ln (Dungeon m) = Dungeon (M.adjust f ln m) - -(!) :: Dungeon -> LevelId -> Level -(!) (Dungeon m) slid = m M.! slid diff --git a/src/DungeonState.hs b/src/DungeonState.hs deleted file mode 100644 --- a/src/DungeonState.hs +++ /dev/null @@ -1,145 +0,0 @@ -module DungeonState where - -import qualified System.Random as R -import qualified Data.List as L -import qualified Control.Monad.State as MState -import qualified Data.Map as M -import qualified Data.IntMap as IM -import Control.Monad - -import Utils.Assert -import Loc -import Level -import qualified Dungeon -import Random -import qualified Config -import WorldLoc -import State -import qualified Feature as F -import qualified Tile -import Content.CaveKind -import Cave -import Content.ItemKind -import qualified Kind -import Item -import Geometry -import Frequency - -listArrayCfg :: Int -> Int -> TileMapXY -> TileMap -listArrayCfg cxsize cysize lmap = - Kind.listArray (zeroLoc, toLoc cxsize (cxsize - 1, cysize - 1)) - (M.elems $ M.mapKeys (\ (x, y) -> (y, x)) lmap) - -unknownTileMap :: Int -> Int -> TileMap -unknownTileMap cxsize cysize = - Kind.listArray (zeroLoc, toLoc cxsize (cxsize - 1, cysize - 1)) - (repeat Tile.unknownId) - -mapToIMap :: X -> M.Map (X, Y) a -> IM.IntMap a -mapToIMap cxsize m = - IM.fromList $ map (\ (xy, a) -> (toLoc cxsize xy, a)) (M.assocs m) - -rollItems :: Int -> CaveKind -> TileMap -> Loc -> Rnd [(Loc, Item)] -rollItems n CaveKind{cxsize, citemNum} lmap ploc = - do - nri <- rollDice citemNum - replicateM nri $ - do - item <- newItem n - l <- case iname (Kind.getKind (jkind item)) of - "sword" -> - -- swords generated close to monsters; MUAHAHAHA - findLocTry 2000 lmap - (const Tile.isBoring) - (\ l _ -> distance cxsize ploc l > 30) - _ -> findLoc lmap - (const Tile.isBoring) - return (l, item) - --- | Create a level from a cave, from a cave kind. -buildLevel :: Cave -> Int -> Int -> Rnd Level -buildLevel Cave{dkind, dsecret, ditem, dmap, dmeta} n depth = do - let cfg@CaveKind{cxsize, cysize, minStairsDistance} = Kind.getKind dkind - cmap = listArrayCfg cxsize cysize dmap - -- Roll locations of the stairs. - su <- findLoc cmap (const Tile.isBoring) - sd <- findLocTry 2000 cmap - (\ l t -> l /= su && Tile.isBoring t) - (\ l _ -> distance cxsize su l >= minStairsDistance) - let stairs = - [(su, Tile.stairsUpId)] - ++ if n == depth then [] else [(sd, Tile.stairsDownId)] - lmap = cmap Kind.// stairs - is <- rollItems n cfg lmap su - let itemMap = mapToIMap cxsize ditem `IM.union` IM.fromList is - litem = IM.map (\ i -> ([i], [])) itemMap - level = Level - { lheroes = emptyParty - , lxsize = cxsize - , lysize = cysize - , lmonsters = emptyParty - , lsmell = IM.empty - , lsecret = mapToIMap cxsize dsecret - , litem - , lmap - , lrmap = unknownTileMap cxsize cysize - , lmeta = dmeta - , lstairs = (su, sd) - } - return level - -matchGenerator :: Maybe String -> Rnd (Kind.Id CaveKind) -matchGenerator Nothing = do - (ci, _) <- frequency Kind.frequency - return ci -matchGenerator (Just "caveRogue") = do - let freq = filterFreq ((== CaveRogue) . clayout . snd) Kind.frequency - (ci, _) <- frequency freq - return ci -matchGenerator (Just "caveEmpty") = do - let freq = filterFreq ((== CaveEmpty) . clayout . snd) Kind.frequency - (ci, _) <- frequency freq - return ci -matchGenerator (Just "caveNoise") = - return $ Kind.getId (\ cc -> clayout cc == CaveNoise && cxsize cc < 100) -matchGenerator (Just s) = - error $ "Unknown dungeon generator " ++ s - -findGenerator :: Config.CP -> Int -> Int -> Rnd Level -findGenerator config n depth = do - let ln = "LambdaCave_" ++ show n - genName = Config.getOption config "dungeon" ln - ci <- matchGenerator genName - cave <- buildCave n ci - buildLevel cave n depth - --- | Generate the dungeon for a new game. -generate :: Config.CP -> Rnd (Loc, LevelId, Dungeon.Dungeon) -generate config = - let depth = Config.get config "dungeon" "depth" - gen :: R.StdGen -> Int -> (R.StdGen, (LevelId, Level)) - gen g k = - let (g1, g2) = R.split g - res = MState.evalState (findGenerator config k depth) g1 - in (g2, (LambdaCave k, res)) - con :: R.StdGen -> ((Loc, LevelId, Dungeon.Dungeon), R.StdGen) - con g = - let (gd, levels) = L.mapAccumL gen g [1..depth] - ploc = fst (lstairs (snd (head levels))) - in ((ploc, LambdaCave 1, Dungeon.fromList levels), gd) - in MState.state con - -whereTo :: State -> Loc -> Maybe WorldLoc -whereTo state@State{slid, sdungeon} loc = - let lvl = slevel state - tile = lvl `at` loc - k | Tile.hasFeature F.Climbable tile = -1 - | Tile.hasFeature F.Descendable tile = 1 - | otherwise = assert `failure` tile - n = levelNumber slid - nln = n + k - ln = LambdaCave nln - lvlTrg = sdungeon Dungeon.! ln - in if (nln < 1) - then Nothing - else Just (ln, (if k == 1 then fst else snd) (lstairs lvlTrg)) diff --git a/src/Effect.hs b/src/Effect.hs deleted file mode 100644 --- a/src/Effect.hs +++ /dev/null @@ -1,44 +0,0 @@ -module Effect where - -import Random - -data Effect = - NoEffect - | Heal -- healing strength in ipower - | Wound !RollDice -- base damage, to-dam bonus in ipower - | Dominate - | SummonFriend - | SummonEnemy - | ApplyPerfume - | Regneration - | Searching - | Teleport - deriving (Show, Eq, Ord) - -effectToName :: Effect -> String -effectToName NoEffect = "" -effectToName Heal = "of healing" -effectToName (Wound (a, b)) = if a == 0 && b == 0 - then "of wounding" - else "(" ++ show a ++ "d" ++ show b ++ ")" -effectToName Dominate = "of domination" -effectToName SummonFriend = "of aid calling" -effectToName SummonEnemy = "of summoning" -effectToName ApplyPerfume = "of rose water" -effectToName Regneration = "of regeneration" -effectToName Searching = "of searching" -effectToName Teleport = "of teleportation" - --- | How much AI benefits from applying the effect. Multipllied by item power. --- Negative means harm to the enemy when thrown. Zero won't ever be used. -effectToBenefit :: Effect -> Int -effectToBenefit NoEffect = 0 -effectToBenefit Heal = 10 -- TODO: depends on (maxhp - hp) -effectToBenefit (Wound _) = -10 -- TODO: dice ignored for now -effectToBenefit Dominate = 0 -- AI can't use this -effectToBenefit SummonFriend = 100 -effectToBenefit SummonEnemy = 0 -effectToBenefit ApplyPerfume = 0 -effectToBenefit Regneration = 0 -- much more benefit from carrying around -effectToBenefit Searching = 0 -- AI does not need to search -effectToBenefit Teleport = 0 -- AI does not know when to teleport diff --git a/src/EffectAction.hs b/src/EffectAction.hs deleted file mode 100644 --- a/src/EffectAction.hs +++ /dev/null @@ -1,309 +0,0 @@ -module EffectAction where - -import Control.Monad -import Control.Monad.State hiding (State, state) -import Data.Function -import qualified Data.List as L -import qualified Data.IntMap as IM -import qualified Data.Set as S -import System.Time - -import Utils.Assert -import Action -import Actor -import ActorState -import Content.ActorKind -import ActorAdd -import Display hiding (display) -import Grammar -import Loc -import qualified HighScores as H -import Item -import Content.ItemKind -import Level -import Message -import Perception -import Random -import State -import qualified Config -import qualified Effect -import qualified Kind - --- The effectToAction function and all it depends on. --- This file should not depend on Action.hs nor ItemAction.hs. - --- | The source actor affects the target actor, with a given effect and power. --- The second argument is verbosity of the resulting message. --- TODO: instead of verbosity return msg components and tailor them outside? --- Both actors are on the current level and can be the same actor. --- The bool result indicates if the actors identify the effect. --- TODO: separately define messages for the case when source == target --- and for the other case; then use the messages outside of effectToAction, --- depending on the returned bool, perception and identity of the actors. -effectToAction :: Effect.Effect -> Int -> ActorId -> ActorId -> Int -> - Action (Bool, String) -effectToAction Effect.NoEffect _ _ _ _ = nullEffect -effectToAction Effect.Heal _ _source target power = do - let bhpMax m = maxDice (ahp $ Kind.getKind $ bkind m) - tm <- gets (getActor target) - if bhp tm >= bhpMax tm || power <= 0 - then nullEffect - else do - focusIfAHero target - updateAnyActor target (addHp power) -- TODO: duplicates maxDice, etc. - return (True, subjectActorVerb tm "feel" ++ " better.") -effectToAction (Effect.Wound nDm) verbosity source target power = do - n <- rndToAction $ rollDice nDm - if n + power <= 0 then nullEffect else do - focusIfAHero target - tm <- gets (getActor target) - let newHP = bhp tm - n - power - killed = newHP <= 0 - msg - | source == target = -- a potion of wounding, etc. - subjectActorVerb tm "feel" ++ - if killed then " mortally" else "" ++ " wounded." - | killed = - if isAHero target then "" else - subjectActorVerb tm "die" ++ "." - | verbosity <= 0 = "" - | isAHero target = - subjectActorVerb tm "lose" ++ - " " ++ show (n + power) ++ "HP." - | otherwise = subjectActorVerb tm "hiss" ++ " in pain." - updateAnyActor target $ \ m -> m { bhp = newHP } -- Damage the target. - when killed $ do - -- Place the actor's possessions on the map. - modify (updateLevel (dropItemsAt (bitems tm) (bloc tm))) - -- Clean bodies up. - pl <- gets splayer - if target == pl - then checkPartyDeath -- kills the player and checks game over - else modify (deleteActor target) -- kills the enemy - return (True, msg) -effectToAction Effect.Dominate _ source target _power = - if isAMonster target -- Monsters have weaker will than heroes. - then do - selectPlayer target - >>= assert `trueM` (source, target, "player dominates himself") - -- Prevent AI from getting a few free moves until new player ready. - updatePlayerBody (\ m -> m { btime = 0}) - display - return (True, "") - else nullEffect -effectToAction Effect.SummonFriend _ source target power = do - tm <- gets (getActor target) - if isAHero source - then summonHeroes (1 + power) (bloc tm) - else summonMonsters (1 + power) (bloc tm) - return (True, "") -effectToAction Effect.SummonEnemy _ source target power = do - tm <- gets (getActor target) - if not $ isAHero source -- a trick: monster player will summon a hero - then summonHeroes (1 + power) (bloc tm) - else summonMonsters (1 + power) (bloc tm) - return (True, "") -effectToAction Effect.ApplyPerfume _ source target _ = - if source == target - then return (True, "Tastes like water, but with a strong rose scent.") - else do - let upd lvl = lvl { lsmell = IM.empty } - modify (updateLevel upd) - return (True, "The fragrance quells all scents in the vicinity.") -effectToAction Effect.Regneration verbosity source target power = - effectToAction Effect.Heal verbosity source target power -effectToAction Effect.Searching _ _source _target _power = - return (True, "It gets lost and you search in vain.") -effectToAction Effect.Teleport _ _ _ _ = nullEffect -- TODO - -nullEffect :: Action (Bool, String) -nullEffect = return (False, "Nothing happens.") - --- | The source actor affects the target actor, with a given item. --- If either actor is a hero, the item may get identified. -itemEffectAction :: Int -> ActorId -> ActorId -> Item -> Action Bool -itemEffectAction verbosity source target item = do - tm <- gets (getActor target) - per <- currentPerception - let effect = ieffect $ Kind.getKind $ jkind item - -- The message describes the target part of the action. - (b, msg) <- effectToAction effect verbosity source target (jpower item) - -- Determine how the player perceives the event. - -- TODO: factor it out as a function messageActor - -- and messageActorVerb (incorporating subjectActorVerb). - if bloc tm `S.member` ptvisible per - then messageAdd msg - else unless b $ - -- victim is not seen and but somethig interestng happens - messageAdd "You hear some noises." - -- If something happens, the item gets identified. - when (b && (isAHero source || isAHero target)) $ discover item - return b - --- | Given item is now known to the player. -discover :: Item -> Action () -discover i = do - state <- get - let ik = jkind i - obj = unwords $ tail $ words $ objectItem state i - msg = "The " ++ obj ++ " turns out to be " - kind = Kind.getKind ik - alreadyIdentified = L.length (iflavour kind) == 1 || - ik `S.member` sdisco state - unless alreadyIdentified $ do - modify (updateDiscoveries (S.insert ik)) - state2 <- get - messageAdd $ msg ++ objectItem state2 i ++ "." - --- | Make the actor controlled by the player. --- Focus on the actor if level changes. False, if nothing to do. -selectPlayer :: ActorId -> Action Bool -selectPlayer actor = - do - pl <- gets splayer - if actor == pl - then return False -- already selected - else do - state <- get - when (absentHero actor state) $ abortWith "No such member of the party." - let (nln, pbody) = findActorAnyLevel actor state - -- Make the new actor the player-controlled actor. - modify (\ s -> s { splayer = actor }) - -- Record the original level of the new player. - modify (updateCursor (\ c -> c { creturnLn = nln })) - -- Don't continue an old run, if any. - stopRunning - -- Switch to the level. - modify (\ s -> s{slid = nln}) - -- Set smell display, depending on player capabilities. - -- This also resets FOV mode. - modify (\ s -> s { ssensory = - if asmell $ Kind.getKind $ - bkind pbody - then Smell - else Implicit }) - -- Announce. - messageAdd $ subjectActor pbody ++ " selected." - return True - -focusIfAHero :: ActorId -> Action () -focusIfAHero target = - when (isAHero target) $ do - -- Focus on the hero being wounded/displaced/etc. - b <- selectPlayer target - -- Display status line for the new hero. - when b $ display >> return () - -summonHeroes :: Int -> Loc -> Action () -summonHeroes n loc = - assert (n > 0) $ do - newHeroId <- gets (fst . scounter) - modify (\ state -> iterate (addHero loc) state !! n) - selectPlayer (AHero newHeroId) - >>= assert `trueM` (newHeroId, "player summons himself") - -- Display status line for the new hero. - display >> return () - -summonMonsters :: Int -> Loc -> Action () -summonMonsters n loc = do - (mk, k) <- rndToAction $ frequency Kind.frequency - hp <- rndToAction $ rollDice $ ahp k - modify (\ state -> - iterate (addMonster mk hp loc) state !! n) - --- | Remove dead heroes (or dominated monsters), check if game over. --- For now we only check the selected hero and at current level, --- but if poison, etc. is implemented, we'd need to check all heroes --- on any level. -checkPartyDeath :: Action () -checkPartyDeath = - do - ahs <- gets allHeroesAnyLevel - pl <- gets splayer - pbody <- gets getPlayerBody - config <- gets sconfig - when (bhp pbody <= 0) $ do -- TODO: change to guard? define mzero? Why are the writes to the files performed when I call abort later? That probably breaks the laws of MonadPlus. - go <- messageMoreConfirm ColorBW $ - subjectActorVerb pbody "die" ++ "." - history -- Prevent the messages from being repeated. - let firstDeathEnds = Config.get config "heroes" "firstDeathEnds" - if firstDeathEnds - then gameOver go - else case L.filter (\ (actor, _) -> actor /= pl) ahs of - [] -> gameOver go - (actor, _nln) : _ -> do - messageAdd "The survivors carry on." - -- Remove the dead player. - modify deletePlayer - -- At this place the invariant that the player exists fails. - -- Focus on the new hero (invariant not needed). - selectPlayer actor - >>= assert `trueM` (pl, actor, "player resurrects") - -- At this place the invariant is restored again. - --- | End game, showing the ending screens, if requested. -gameOver :: Bool -> Action () -gameOver showEndingScreens = - do - when showEndingScreens $ do - state <- get - slid <- gets slid - let total = calculateTotal state - status = H.Killed slid - handleScores True status total - messageMore "Let's hope another party can save the day!" - end - --- | Calculate loot's worth for heroes on the current level. -calculateTotal :: State -> Int -calculateTotal s = - L.sum $ L.map itemPrice $ L.concatMap bitems (levelHeroList s) - --- | Handle current score and display it with the high scores. Scores --- should not be shown during the game, --- because ultimately the worth of items might give --- information about the nature of the items. --- False if display of the scores was void or interrupted by the user -handleScores :: Bool -> H.Status -> Int -> Action Bool -handleScores write status total = - if total == 0 - then return False - else do - config <- gets sconfig - time <- gets stime - curDate <- liftIO getClockTime - let points = case status of - H.Killed _ -> (total + 1) `div` 2 - _ -> total - let score = H.ScoreRecord points (-time) curDate status - (placeMsg, slideshow) <- liftIO $ H.register config write score - messageOverlaysConfirm placeMsg slideshow - --- effectToAction does not depend on this function right now, but it might, --- and I know no better place to put it. -displayItems :: Message -> Bool -> [Item] -> Action Bool -displayItems msg sorted is = do - state <- get - let inv = unlines $ - L.map (\ i -> letterLabel (jletter i) ++ objectItem state i ++ " ") - ((if sorted then L.sortBy (cmpLetter' `on` jletter) else id) is) - let ovl = inv ++ more - messageReset msg - overlay ovl - -stopRunning :: Action () -stopRunning = updatePlayerBody (\ p -> p { bdir = Nothing }) - --- | Store current message in the history and reset current message. -history :: Action () -history = - do - sx <- gets (lxsize . slevel) - msg <- currentMessage - messageClear - config <- gets sconfig - let historyMax = Config.get config "ui" "historyMax" - -- TODO: not ideal, continuations of sentences are atop beginnings. - splitS = splitMsg (sx + 1) (msg ++ " ") - unless (L.null msg) $ - modify (updateHistory (take historyMax . (L.reverse splitS ++))) diff --git a/src/FOV.hs b/src/FOV.hs deleted file mode 100644 --- a/src/FOV.hs +++ /dev/null @@ -1,58 +0,0 @@ -module FOV (FovMode(..), fullscan) where - -import qualified Data.Set as S -import qualified Data.List as L - -import FOV.Common -import qualified FOV.Digital -import qualified FOV.Permissive -import qualified FOV.Shadow -import Loc -import Level - --- TODO: should Blind really be a FovMode, or a modifier? Let's decide --- when other similar modifiers are added. -data FovMode = Shadow | Permissive Int | Digital Int | Blind - --- | Perform a full scan for a given location. Returns the locations --- that are currently in the field of view. The Field of View --- algorithm to use is set in the config file. --- Press a command key in the game to cycle among the algorithms --- and see a special visualization of their effects.. -fullscan :: FovMode -> Loc -> Level -> S.Set Loc -fullscan fovMode loc lvl@Level{lxsize} = - case fovMode of - Shadow -> -- shadow casting with infinite range - S.unions $ - L.map (\ tr -> FOV.Shadow.scan tr lvl 1 (0,1)) - [tr0, tr1, tr2, tr3, tr4, tr5, tr6, tr7] - Permissive r -> -- permissive with range r - S.unions $ - L.map (\ tr -> FOV.Permissive.scan r tr lvl) [qtr0, qtr1, qtr2, qtr3] - Digital r -> -- digital with range r - S.unions $ - L.map (\ tr -> FOV.Digital.scan r tr lvl) [qtr0, qtr1, qtr2, qtr3] - Blind -> -- only feeling out adjacent tiles by touch - let radius = 1 - in S.unions $ - L.map (\ tr -> FOV.Digital.scan radius tr lvl) [qtr0, qtr1, qtr2, qtr3] - where - trL = trLoc lxsize - - -- | The translation, rotation and symmetry functions for octants. - tr0, tr1, tr2, tr3, tr4, tr5, tr6, tr7 :: (Distance, Progress) -> Loc - tr0 (p, d) = trL loc ( p, d) - tr1 (p, d) = trL loc (- p, d) - tr2 (p, d) = trL loc ( p, - d) - tr3 (p, d) = trL loc (- p, - d) - tr4 (p, d) = trL loc ( d, p) - tr5 (p, d) = trL loc (- d, p) - tr6 (p, d) = trL loc ( d, - p) - tr7 (p, d) = trL loc (- d, - p) - - -- | The translation and rotation functions for quadrants. - qtr0, qtr1, qtr2, qtr3 :: Bump -> Loc - qtr0 (B(x, y)) = trL loc ( x, - y) -- quadrant I - qtr1 (B(x, y)) = trL loc ( y, x) -- II (we rotate counter-clockwise) - qtr2 (B(x, y)) = trL loc (- x, y) -- III - qtr3 (B(x, y)) = trL loc (- y, - x) -- IV diff --git a/src/FOV/Common.hs b/src/FOV/Common.hs deleted file mode 100644 --- a/src/FOV/Common.hs +++ /dev/null @@ -1,60 +0,0 @@ -module FOV.Common - ( Distance, Progress - , Bump(..) - , Line, ConvexHull, Edge, EdgeInterval - , isClear, divUp, maximal, steeper, addHull - ) where - -import qualified Data.List as L - -import Geometry -import Loc -import qualified Tile -import Level - -type Distance = Int -type Progress = Int - --- | Rotated and translated coordinates of 2D points, so that the points fit --- in a single quadrant area (quadrant I for Permissive FOV, hence both --- coordinates positive, and adjacent diagonal halves of quadrant I and II --- for Digital FOV, hence y positive). --- The coordinates are written using the standard mathematical coordinate setup, --- where quadrant I, with x and y positive, is on the upper right. -newtype Bump = B (X, Y) - deriving (Show) - -type Line = (Bump, Bump) -type ConvexHull = [Bump] -type Edge = (Line, ConvexHull) -type EdgeInterval = (Edge, Edge) - -isClear :: Level -> (Bump -> Loc) -> Bump -> Bool -isClear l tr = Tile.isClear . (l `at`) . tr - --- | Integer division, rounding up. -divUp :: Int -> Int -> Int -divUp n k = (n + k - 1) `div` k - --- | Maximal element of a non-empty list. Prefers elements from the rear, --- which is essential for PFOV, to avoid ill-defined lines. -maximal :: (a -> a -> Bool) -> [a] -> a -maximal gte = L.foldl1' (\ acc e -> if gte e acc then e else acc) - --- | 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 in this particular setup. Returns True for ill-defined lines. -steeper :: Bump -> Bump -> Bump -> Bool -steeper (B(xf, yf)) (B(x1, y1)) (B(x2, y2)) = - (yf - y1)*(xf - x2) >= (yf - y2)*(xf - x1) - --- | Adds a bump to the convex hull of bumps represented as a list. -addHull :: (Bump -> Bump -> Bool) -> Bump -> ConvexHull -> ConvexHull -addHull gte d l = - case l of - a:b:cs -> - if gte a b - then addHull gte d (b:cs) - else d : l - _ -> d : l diff --git a/src/FOV/Digital.hs b/src/FOV/Digital.hs deleted file mode 100644 --- a/src/FOV/Digital.hs +++ /dev/null @@ -1,149 +0,0 @@ -module FOV.Digital (scan) where - -import qualified Data.Set as S - -import Utils.Assert -import FOV.Common -import Loc -import Level - --- Digital FOV with a given range. - --- | DFOV, according to specification at http://roguebasin.roguelikedevelopment.org/index.php?title=Digital_field_of_view_implementation, --- but AFAIK, this algorithm (fast DFOV done similarly as PFOV) has never been --- implemented before. The algorithm is based on the PFOV algorithm, --- clean-room reimplemented based on http://roguebasin.roguelikedevelopment.org/index.php?title=Precise_Permissive_Field_of_View. --- See https://github.com/Mikolaj/Allure/wiki/Fov-and-los --- for some more context. - --- | The current state of a scan is kept in Maybe (Line, ConvexHull). --- If Just something, we're in a visible interval. If Nothing, we're in --- a shadowed interval. -scan :: Distance -> (Bump -> Loc) -> Level -> S.Set Loc -scan r tr l = - -- the scanned area is a square, which is a sphere in this metric; good - dscan 1 (((B(1, 0), B(-r, r)), [B(0, 0)]), ((B(0, 0), B(r+1, r)), [B(1, 0)])) - where - dscan :: Distance -> EdgeInterval -> S.Set Loc - dscan d (s0@(sl{-shallow line-}, sBumps0), e@(el{-steep line-}, eBumps)) = - let ps0 = let (n, k) = intersect sl d -- minimal progress to consider - in n `div` k - pe = let (n, k) = intersect el d -- maximal progress to consider - -- Corners obstruct view, so the steep line, constructed - -- from corners, is itself not a part of the view, - -- so if its intersection with the line of diagonals is only - -- at a corner, choose the diamond leading to a smaller view. - in -1 + n `divUp` k - - inside = S.fromList [tr (B(p, d)) | p <- [ps0..pe]] - outside - | d >= r = S.empty - | isClear l tr (B(ps0, d)) = - mscan (Just s0) (ps0+1) pe -- start in light - | otherwise = - mscan Nothing (ps0+1) pe -- start in shadow - in assert (r >= d && d >= 0 && pe >= ps0 `blame` (r,d,s0,e,ps0,pe)) $ - S.union inside outside - where - mscan :: Maybe Edge -> Progress -> Progress -> S.Set Loc - mscan (Just s@(_, sBumps)) ps pe - | ps > pe = dscan (d+1) (s, e) -- reached end, scan next - | not $ isClear l tr steepBump = -- entering shadow - S.union (dscan (d+1) (s, (dline nep steepBump, neBumps))) - (mscan Nothing (ps+1) pe) - | otherwise = mscan (Just s) (ps+1) pe -- continue in light - where - steepBump = B(ps, d) - gte = dsteeper steepBump - nep = maximal gte sBumps - neBumps = addHull gte steepBump eBumps - - mscan Nothing ps pe - | ps > pe = S.empty -- reached end while in shadow - | isClear l tr shallowBump = -- moving out of shadow - mscan (Just (dline nsp shallowBump, nsBumps)) (ps+1) pe - | otherwise = mscan Nothing (ps+1) pe -- continue in shadow - where - shallowBump = B(ps, d) - gte = flip $ dsteeper shallowBump - nsp = maximal gte eBumps - nsBumps = addHull gte shallowBump sBumps0 - --- | Create a line from two points. Debug: check if well-defined. -dline :: Bump -> Bump -> Line -dline p1 p2 = - assert (uncurry blame $ debugLine (p1, p2)) $ - (p1, p2) - --- | Compare steepness of (p1, f) and (p2, f). --- Debug: Verify that the results of 2 independent checks are equal. -dsteeper :: Bump -> Bump -> Bump -> Bool -dsteeper f p1 p2 = - assert (res == debugSteeper f p1 p2) $ - res - where res = steeper f p1 p2 - --- | The 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) -intersect (B(x, y), B(xf, yf)) d = - assert (allB (>= 0) [y, yf]) $ - ((d - y)*(xf - x) + x*(yf - y), yf - y) -{- -Derivation of the formula: -The intersection point (xt, yt) satisfies the following equalities: -yt = d -(yt - y) (xf - x) = (xt - x) (yf - y) -hence -(yt - y) (xf - x) = (xt - x) (yf - y) -(d - y) (xf - x) = (xt - x) (yf - y) -(d - y) (xf - x) + x (yf - y) = xt (yf - y) -xt = ((d - y) (xf - x) + x (yf - y)) / (yf - y) - -General remarks: -A diamond is denoted by its left corner. Hero at (0, 0). -Order of processing in the first quadrant rotated by 45 degrees is - 45678 - 123 - @ -so the first processed diamond is at (-1, 1). The order is similar -as for the restrictive shadow casting algorithm and reversed wrt PFOV. -The line in the curent state of mscan is called the shallow line, -but it's the one that delimits the view from the left, while the steep -line is on the right, opposite to PFOV. We start scanning from the left. - -The Loc coordinates are cartesian. The Bump coordinates are cartesian, -translated so that the hero is at (0, 0) and rotated so that he always -looks at the first (rotated 45 degrees) quadrant. The (Progress, Distance) -cordinates coincide with the Bump coordinates, unlike in PFOV. --} - --- | Debug functions for DFOV: - --- | Debug: calculate steeper for DFOV in another way and compare results. -debugSteeper :: Bump -> Bump -> Bump -> Bool -debugSteeper f@(B(_xf, yf)) p1@(B(_x1, y1)) p2@(B(_x2, y2)) = - assert (allB (>= 0) [yf, y1, y2]) $ - let (n1, k1) = intersect (p1, f) 0 - (n2, k2) = intersect (p2, f) 0 - in n1 * k2 >= k1 * n2 - --- | Debug: check is a view border line for DFOV is legal. -debugLine :: Line -> (Bool, String) -debugLine 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) = intersect line 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) diff --git a/src/FOV/Permissive.hs b/src/FOV/Permissive.hs deleted file mode 100644 --- a/src/FOV/Permissive.hs +++ /dev/null @@ -1,159 +0,0 @@ -module FOV.Permissive (scan) where - -import qualified Data.Set as S - -import Utils.Assert -import FOV.Common -import Loc -import Level - --- Permissive FOV with a given range. - --- | PFOV, clean-room reimplemented based on the algorithm described in http://roguebasin.roguelikedevelopment.org/index.php?title=Precise_Permissive_Field_of_View, --- though the general structure is more influenced by recursive shadow casting, --- as implemented in Shadow.hs. In the result, this algorithm is much faster --- than the original algorithm on dense maps, since it does not scan --- areas blocked by shadows. --- See https://github.com/Mikolaj/Allure/wiki/Fov-and-los --- for some more context. - --- TODO: Scanning squares on horizontal lines in octants, not squares --- on diagonals in quadrants, may be much faster and a bit simpler. --- Right now we build new view on each end of each visible wall tile --- and this is necessary only for straight, thin, diagonal walls. - --- | The current state of a scan is kept in Maybe (Line, ConvexHull). --- If Just something, we're in a visible interval. If Nothing, we're in --- a shadowed interval. -scan :: Distance -> (Bump -> Loc) -> Level -> S.Set Loc -scan r tr l = - -- the area is diagonal, which is incorrect, but looks good enough - dscan 1 (((B(0, 1), B(r+1, 0)), [B(1, 0)]), ((B(1, 0), B(0, r+1)), [B(0, 1)])) - where - dscan :: Distance -> EdgeInterval -> S.Set Loc - dscan d (s0@(sl{-shallow line-}, sBumps0), e@(el{-steep line-}, eBumps)) = - assert (r >= d && d >= 0 && pe + 1 >= ps0 && ps0 >= 0 - `blame` (r,d,s0,e,ps0,pe)) $ - if illegal then S.empty else S.union inside outside - where - (ns, ks) = intersect sl d - (ne, ke) = intersect el d - -- Corners are translucent, so they are invisible, so if intersection - -- is at a corner, choose pe that creates the smaller view. - (ps0, pe) = (ns `div` ks, ne `divUp` ke - 1) -- progress interval to check - -- Single ray from an extremity, produces non-permissive digital lines. - illegal = let (n, k) = intersect sl 0 - in ns*ke == ne*ks && (n `elem` [0, k]) - pd2bump (p, di) = B(di - p , p) - bottomRight (p, di) = B(di - p + 1, p) - - inside = S.fromList [tr (pd2bump (p, d)) | p <- [ps0..pe]] - outside - | d >= r = S.empty - | isClear l tr (pd2bump (ps0, d)) = mscan (Just s0) ps0 -- start in light - | ps0 == ns `divUp` ks = mscan (Just s0) ps0 -- start in a corner - | otherwise = mscan Nothing (ps0+1) -- start in mid-wall - - mscan :: Maybe Edge -> Progress -> S.Set Loc - mscan (Just s@(_, sBumps)) ps - | ps > pe = dscan (d+1) (s, e) -- reached end, scan next - | not $ isClear l tr (pd2bump (ps, d)) = -- enter shadow, steep bump - let steepBump = bottomRight (ps, d) - gte = flip $ dsteeper steepBump - -- sBumps may contain steepBump, but maximal will ignore it - nep = maximal gte sBumps - neBumps = addHull gte steepBump eBumps - in S.union (dscan (d+1) (s, (dline nep steepBump, neBumps))) - (mscan Nothing (ps+1)) - | otherwise = mscan (Just s) (ps+1) -- continue in light - - mscan Nothing ps - | ps > ne `div` ke = S.empty -- reached absolute end - | otherwise = -- out of shadow, shallow bump - -- the light can be just through a corner of diagonal walls - -- and the recursive call verifies that at the same ps coordinate - let shallowBump = bottomRight (ps, d) - gte = dsteeper shallowBump - nsp = maximal gte eBumps - nsBumps = addHull gte shallowBump sBumps0 - in mscan (Just (dline nsp shallowBump, nsBumps)) ps - --- | Create a line from two points. Debug: check if well-defined. -dline :: Bump -> Bump -> Line -dline p1 p2 = - assert (uncurry blame $ debugLine (p1, p2)) $ - (p1, p2) - --- | Compare steepness of (p1, f) and (p2, f). --- Debug: Verify that the results of 2 independent checks are equal. -dsteeper :: Bump -> Bump -> Bump -> Bool -dsteeper f p1 p2 = - assert (res == debugSteeper f p1 p2) $ - res - where res = steeper f p1 p2 - --- | The y coordinate, represented as a fraction, of the intersection of --- a given line and the line of diagonals of squares at distance d from (0, 0). -intersect :: Line -> Distance -> (Int, Int) -intersect (B(x, y), B(xf, yf)) d = - assert (allB (>= 0) [x, y, xf, yf]) $ - ((1 + d)*(yf - y) + y*xf - x*yf, (xf - x) + (yf - y)) -{- -Derivation of the formula: -The intersection point (xt, yt) satisfies the following equalities: -xt = 1 + d - yt -(yt - y) (xf - x) = (xt - x) (yf - y) -hence -(yt - y) (xf - x) = (xt - x) (yf - y) -yt (xf - x) - y xf = xt (yf - y) - x yf -yt (xf - x) - y xf = (1 + d) (yf - y) - yt (yf - y) - x yf -yt (xf - x) + yt (yf - y) = (1 + d) (yf - y) - x yf + y xf -yt = ((1 + d) (yf - y) + y xf - x yf) / (xf - x + yf - y) - -General remarks: -A square is denoted by its bottom-left corner. Hero at (0, 0). -Order of processing in the first quadrant is -9 -58 -247 -@136 -so the first processed square is at (0, 1). The order is reversed -wrt the restrictive shadow casting algorithm. The line in the curent state -of mscan is not the steep line, but the shallow line, -and we start scanning from the bottom right. - -The Loc coordinates are cartesian. The Bump coordinates are cartesian, -translated so that the hero is at (0, 0) and rotated so that he always -looks at the first quadrant. The (Progress, Distance) cordinates -are mangled and not used for geometry. --} - --- | Debug functions for PFOV: - --- | Debug: calculate steeper for PFOV in another way and compare results. -debugSteeper :: Bump -> Bump -> Bump -> Bool -debugSteeper f@(B(xf, yf)) p1@(B(x1, y1)) p2@(B(x2, y2)) = - assert (allB (>= 0) [xf, yf, x1, y1, x2, y2]) $ - let (n1, k1) = intersect (p1, f) 0 - (n2, k2) = intersect (p2, f) 0 - in n1 * k2 <= k1 * n2 - --- | Debug: checks postconditions of borderLine. -debugLine :: Line -> (Bool, String) -debugLine line@(B(x1, y1), B(x2, y2)) - | not (allB (>= 0) [x1, y1, x2, y2]) = - (False, "negative coordinates: " ++ show line) - | y1 == y2 && x1 == x2 = - (False, "ill-defined line: " ++ show line) - | x2 - x1 == - (y2 - y1) = - (False, "diagonal line: " ++ show line) - | crossL0 = - (False, "crosses diagonal below 0: " ++ show line) - | crossG1 = - (False, "crosses diagonal above 1: " ++ show line) - | otherwise = (True, "") - where - (n, k) = intersect line 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) diff --git a/src/FOV/Shadow.hs b/src/FOV/Shadow.hs deleted file mode 100644 --- a/src/FOV/Shadow.hs +++ /dev/null @@ -1,110 +0,0 @@ -module FOV.Shadow (scan) where - -import Data.Ratio -import qualified Data.Set as S - -import Utils.Assert -import FOV.Common -import Loc -import Level -import qualified Tile - --- Recursive Shadow Casting. - --- | A restrictive variant of Recursive Shadow Casting FOV with infinite range. --- It's not designed for dungeons with diagonal walls, so they block visibility, --- though they don't block movement. Such cases appear in the game only --- when two corridors touch diagonally by accident and on the random pillars --- levels. - -{- -Field Of View -------------- - -The algorithm used is a variant of Shadow Casting. We first compute -fields that are reachable (have unobstructed line of sight) from the hero's -position. Later, in Perception.hs, from this information we compute -the fields that are visible (not hidden in darkness, etc.). - -As input to the algorithm, we require information about fields that -block light. As output, we get information on the reachability of all fields. -We assume that the hero is located at position (0, 0) -and we only consider fields (line, row) where line >= 0 and 0 <= row <= line. -This is just about one eighth of the whole hero's surroundings, -but the other parts can be computed in the same fashion by mirroring -or rotating the given algorithm accordingly. - - fov (blocks, maxline) = - shadow := \empty_set - reachable (0, 0) := True - for l \in [ 1 .. maxline ] do - for r \in [ 0 .. l ] do - reachable (l, r) := ( \exists a. a \in interval (l, r) \and - a \not_in shadow) - if blocks (l, r) then - shadow := shadow \union interval (l, r) - end if - end for - end for - return reachable - - interval (l, r) = return [ angle (l + 0.5, r - 0.5), - angle (l - 0.5, r + 0.5) ] - angle (l, r) = return atan (r / l) - -The algorithm traverses the fields line by line, row by row. -At every moment, we keep in shadow the intervals which are in shadow, -measured by their angle. A square is reachable when any point -in it is not in shadow --- the algorithm is permissive in this respect. -We could also require that a certain fraction of the field is reachable, -or a specific point. Our choice has certain consequences. For instance, -a single blocking field throws a shadow, but the fields immediately behind -the blocking field are still visible. - -We can compute the interval of angles corresponding to one square field -by computing the angle of the line passing the upper left corner -and the angle of the line passing the lower right corner. -This is what interval and angle do. If a field is blocking, the interval -for the square is added to the shadow set. --} - -type Interval = (Rational, Rational) - --- | The current state of a scan is kept in a variable of Maybe Rational. --- If Just something, we're in a visible interval. If Nothing, we're in --- a shadowed interval. -scan :: ((Progress, Distance) -> Loc) -> Level -> Distance -> Interval - -> S.Set Loc -scan tr l d (s0, e) = - let ps = downBias (s0 * fromIntegral d) -- minimal progress to check - pe = upBias (e * fromIntegral d) -- maximal progress to check - st = if Tile.isClear (l `at` tr (ps, d)) - then Just s0 -- start in light - else Nothing -- start in shadow - in - assert (d >= 0 && e >= 0 && s0 >= 0 && pe >= ps && ps >= 0 - `blame` (d,s0,e,ps,pe)) $ - S.union (S.fromList [tr (p, d) | p <- [ps..pe]]) (mscan st ps pe) - where - mscan :: Maybe Rational -> Progress -> Progress -> S.Set Loc - mscan (Just s) ps pe - | s >= e = S.empty -- empty interval - | ps > pe = scan tr l (d+1) (s, e) -- reached end, scan next - | not $ Tile.isClear (l `at` tr (ps, d)) = - let ne = (fromIntegral ps - (1%2)) / (fromIntegral d + (1%2)) - in scan tr l (d+1) (s, ne) `S.union` mscan Nothing (ps+1) pe - -- entering shadow - | otherwise = mscan (Just s) (ps+1) pe - -- continue in light - mscan Nothing ps pe - | ps > pe = S.empty -- reached end while in shadow - | Tile.isClear (l `at` tr (ps, d)) = - let ns = (fromIntegral ps - (1%2)) / (fromIntegral d - (1%2)) - in mscan (Just ns) (ps+1) pe - -- moving out of shadow - | otherwise = mscan Nothing (ps+1) pe - -- continue in shadow - -downBias, upBias :: (Integral a, Integral b) => Ratio a -> b -downBias x = round (x - 1 % (denominator x * 3)) -upBias x = round (x + 1 % (denominator x * 3)) diff --git a/src/Feature.hs b/src/Feature.hs deleted file mode 100644 --- a/src/Feature.hs +++ /dev/null @@ -1,20 +0,0 @@ -module Feature (Feature(..)) where - -import Effect -import Random - -data Feature = - Walkable -- ^ actors can walk through - | Clear -- ^ actors can see through - | Exit -- ^ is an exit from a room - | Lit -- ^ is lit; TODO: (partially) replace ucolor by this feature? - | Secret !RollDice -- ^ tile is generated with this high secrecy value - | Aura !Effect -- ^ sustains the effect continuously - | Cause !Effect -- ^ causes the effect when triggered - | Change !Char -- ^ transitions when triggered - | Climbable -- ^ triggered by climbing - | Descendable -- ^ triggered by descending into - | Openable -- ^ triggered by opening - | Closable -- ^ triggered by closable - | Hidden -- ^ triggered when the tile's secrecy becomes (Just 0) - deriving (Show, Eq, Ord) diff --git a/src/Flavour.hs b/src/Flavour.hs deleted file mode 100644 --- a/src/Flavour.hs +++ /dev/null @@ -1,68 +0,0 @@ -module Flavour - ( Flavour - , zipPlain, zipFancy, darkCol, brightCol, stdCol, stdFlav - , flavourToColor, flavourToName) - where - -import qualified Data.List as L -import Color - --- TODO: add more variety, as the number of items increases -type Flavour = (Color, Bool) -- the flag tells to use fancy color names - -zipPlain, zipFancy :: [Color] -> [(Color, Bool)] -zipPlain cs = L.zip cs (repeat False) -zipFancy cs = L.zip cs (repeat True) - -darkCol, brightCol, stdCol :: [Color] -darkCol = [Red .. Cyan] -brightCol = [BrRed .. BrCyan] -- BrBlack is not really that bright -stdCol = darkCol ++ brightCol - -stdFlav :: [(Color, Bool)] -stdFlav = zipPlain stdCol ++ zipFancy stdCol - -flavourToName :: Flavour -> String -flavourToName (c, False) = colorToName c -flavourToName (c, True) = colorToName' c - -flavourToColor :: Flavour -> Color -flavourToColor (c, _) = c - --- Human-readable names, for item descriptions. The simple set. -colorToName :: Color -> String -colorToName Black = "black" -colorToName Red = "red" -colorToName Green = "green" -colorToName Yellow = "brown" -colorToName Blue = "blue" -colorToName Magenta = "purple" -colorToName Cyan = "cyan" -colorToName White = "ivory" -colorToName BrBlack = "gray" -colorToName BrRed = "coral" -colorToName BrGreen = "lime" -colorToName BrYellow = "yellow" -colorToName BrBlue = "azure" -colorToName BrMagenta = "pink" -colorToName BrCyan = "aquamarine" -colorToName BrWhite = "white" - --- The fancy set. -colorToName' :: Color -> String -colorToName' Black = "smoky black" -colorToName' Red = "apple red" -colorToName' Green = "forest green" -colorToName' Yellow = "mahogany" -colorToName' Blue = "royal blue" -colorToName' Magenta = "indigo" -colorToName' Cyan = "teal" -colorToName' White = "silver gray" -colorToName' BrBlack = "charcoal" -colorToName' BrRed = "salmon" -colorToName' BrGreen = "emerald" -colorToName' BrYellow = "amber" -colorToName' BrBlue = "sky blue" -colorToName' BrMagenta = "magenta" -colorToName' BrCyan = "turquoise" -colorToName' BrWhite = "ghost white" diff --git a/src/Frequency.hs b/src/Frequency.hs deleted file mode 100644 --- a/src/Frequency.hs +++ /dev/null @@ -1,36 +0,0 @@ -module Frequency where - -import Control.Monad - --- TODO: perhaps move to Utils/ (generally useful enough? more ops needed?) - -newtype Frequency a = Frequency { runFrequency :: [(Int, a)] } - deriving Show - -instance Monad Frequency where - return x = Frequency [(1, x)] - m >>= f = Frequency - [(p * q, y) | (p, x) <- runFrequency m, - (q, y) <- runFrequency (f x) ] - fail _ = Frequency [] - -instance MonadPlus Frequency where - mplus (Frequency xs) (Frequency ys) = Frequency (xs ++ ys) - mzero = Frequency [] - -instance Functor Frequency where - fmap f (Frequency xs) = Frequency (map (\ (p, x) -> (p, f x)) xs) - --- only try the second possibility if the first fails -melse :: Frequency a -> Frequency a -> Frequency a -melse (Frequency []) y = y -melse x _y = x - -scale :: Int -> Frequency a -> Frequency a -scale n (Frequency xs) = Frequency (map (\ (p, x) -> (n * p, x)) xs) - -uniform :: [a] -> Frequency a -uniform = Frequency . map (\ x -> (1, x)) - -filterFreq :: (a -> Bool) -> Frequency a -> Frequency a -filterFreq p (Frequency l) = Frequency $ filter (p . snd) l diff --git a/src/Geometry.hs b/src/Geometry.hs deleted file mode 100644 --- a/src/Geometry.hs +++ /dev/null @@ -1,29 +0,0 @@ -module Geometry - ( Time, X, Y, shiftXY, movesXY, lenXY, euclidLenSq, normalLevelBound ) where - --- | Game time in turns. The time dimension. -type Time = Int - --- | Spacial dimensions, points and vectors. -type X = Int -type Y = Int - --- | Shift a point by a vector. -shiftXY :: (X, Y) -> (X, Y) -> (X, Y) -shiftXY (x0, y0) (x1, y1) = (x0 + x1, y0 + y1) - --- | Vectors of all unit moves, clockwise, starting north-west. -movesXY :: [(X, Y)] -movesXY = [(-1, -1), (0, -1), (1, -1), (1, 0), (1, 1), (0, 1), (-1, 1), (-1, 0)] - --- | The lenght of a vector in our metric where diagonal moves cost 1 move. -lenXY :: (X, Y) -> Int -lenXY (x, y) = max (abs x) (abs y) - --- | Squared euclidean length of a vector. -euclidLenSq :: (X, Y) -> Int -euclidLenSq (x, y) = let square a = a * a - in square x + square y - -normalLevelBound :: (X, Y) -normalLevelBound = (79, 22) -- TODO: query terminal size instead diff --git a/src/Grammar.hs b/src/Grammar.hs deleted file mode 100644 --- a/src/Grammar.hs +++ /dev/null @@ -1,87 +0,0 @@ -module Grammar where - -import Data.Char -import qualified Data.Set as S -import qualified Data.List as L -import Data.Maybe - -import Item -import Actor -import Content.ActorKind -import State -import Content.ItemKind -import Effect -import Flavour -import qualified Kind - -suffixS :: String -> String -suffixS word = case last word of - 'y' -> init word ++ "ies" - 's' -> word ++ "es" - 'x' -> word ++ "es" - _ -> word ++ "s" - -capitalize :: String -> String -capitalize [] = [] -capitalize (c : cs) = toUpper c : cs - -makeObject :: Int -> (String -> String) -> String -> String -makeObject 1 adj obj = let b = adj obj - in case b of - (c:_) | c `elem` "aeio" -> "an " ++ b - _ -> "a " ++ b -makeObject n adj obj = show n ++ " " ++ adj (suffixS obj) - --- TODO: when there's more of the above, split and move to Utils/ - --- | How to refer to an actor in object position of a sentence. -objectActor :: Actor -> String -objectActor a = fromMaybe (aname $ Kind.getKind $ bkind a) (bname a) - --- | How to refer to an actor in subject position of a sentence. -subjectActor :: Actor -> String -subjectActor x = capitalize $ objectActor x - -verbActor :: Actor -> String -> String -verbActor a v = if objectActor a == "you" then v else suffixS v - --- | Sentences such like "The dog barks". -subjectActorVerb :: Actor -> String -> String -subjectActorVerb x v = subjectActor x ++ " " ++ verbActor x v - -compoundVerbActor :: Actor -> String -> String -> String -compoundVerbActor m v p = verbActor m v ++ " " ++ p - -subjectVerbIObject :: State -> Actor -> String -> Item -> String -> String -subjectVerbIObject state m v o add = - subjectActor m ++ " " ++ - verbActor m v ++ " " ++ - objectItem state o ++ add ++ "." - -subjectVerbMObject :: Actor -> String -> Actor -> String -> String -subjectVerbMObject m v o add = - subjectActor m ++ " " ++ - verbActor m v ++ " " ++ - objectActor o ++ add ++ "." - -subjCompoundVerbIObj :: State -> Actor -> String -> String -> - Item -> String -> String -subjCompoundVerbIObj state m v p o add = - subjectActor m ++ " " ++ - compoundVerbActor m v p ++ " " ++ - objectItem state o ++ add ++ "." - -objectItem :: State -> Item -> String -objectItem state o = - let ik = jkind o - kind = Kind.getKind ik - identified = L.length (iflavour kind) == 1 || - ik `S.member` sdisco state - addSpace s = if s == "" then "" else " " ++ s - eff = effectToName (ieffect kind) - pwr = if jpower o == 0 then "" else "(+" ++ show (jpower o) ++ ")" - adj name = if identified - then name ++ addSpace eff ++ addSpace pwr - else let flavour = getFlavour (sflavour state) ik - in flavourToName flavour ++ " " ++ name - in makeObject (jcount o) adj (iname kind) diff --git a/src/HighScores.hs b/src/HighScores.hs deleted file mode 100644 --- a/src/HighScores.hs +++ /dev/null @@ -1,150 +0,0 @@ -module HighScores where - -import System.Directory -import Control.Monad -import Text.Printf -import System.Time - -import Data.Binary -import qualified Data.List as L - -import Utils.File -import qualified Config -import WorldLoc -import Geometry - --- | A single score. --- TODO: add heroes' names, exp and level, cause of death, user number/name. --- Note: I tried using Date.Time, but got all kinds of problems, --- including build problems and opaque types that make serialization difficult, --- and I couldn't use Datetime because it needs old base (and is under GPL). --- TODO: When we finally move to Date.Time, let's take timezone into account. -data ScoreRecord = ScoreRecord - { points :: !Int - , negTurn :: !Int - , date :: !ClockTime - , status :: !Status - } - deriving (Eq, Ord) - -data Status = Killed !LevelId | Camping !LevelId | Victor - deriving (Eq, Ord) - -instance Binary Status where - put (Killed ln) = putWord8 0 >> put ln - put (Camping ln) = putWord8 1 >> put ln - put Victor = putWord8 2 - get = do - tag <- getWord8 - case tag of - 0 -> liftM Killed get - 1 -> liftM Camping get - 2 -> return Victor - _ -> fail "no parse (Status)" - -instance Binary ScoreRecord where - put (ScoreRecord p n (TOD cs cp) s) = - do - put p - put n - put cs - put cp - put s - get = - do - p <- get - n <- get - cs <- get - cp <- get - s <- get - return (ScoreRecord p n (TOD cs cp) s) - --- | Show a single high score. -showScore :: (Int, ScoreRecord) -> String -showScore (pos, score) = - let died = - case status score of - Killed (LambdaCave n) -> "perished on level " ++ show n ++ "," - Camping (LambdaCave n) -> "is camping on level " ++ show n ++ "," - Victor -> "emerged victorious" - time = calendarTimeToString . toUTCTime . date $ score - big = " " - lil = " " - steps = negTurn score `div` (-10) - in - printf - "%s\n%4d. %6d This adventuring party %s after %d steps \n%son %s. \n" - big pos (points score) died steps lil time - --- | The list of scores, in decreasing order. -type ScoreTable = [ScoreRecord] - --- | Empty score table -empty :: ScoreTable -empty = [] - --- | Name of the high scores file. -file :: Config.CP -> IO String -file config = Config.getFile config "files" "highScores" - --- | We save a simple serialized version of the high scores table. --- The 'False' is used only as an EOF marker. -save :: Config.CP -> ScoreTable -> IO () -save config scores = do - f <- file config - encodeEOF f scores - --- | Read the high scores table. Return the empty table if no file. -restore :: Config.CP -> IO ScoreTable -restore config = do - f <- file config - b <- doesFileExist f - if not b - then return [] - else do - scores <- strictDecodeEOF f - return scores - --- | Insert a new score into the table, Return new table and the position. -insertPos :: ScoreRecord -> ScoreTable -> (ScoreTable, Int) -insertPos s h = - let (prefix, suffix) = L.span (> s) h in - (prefix ++ [s] ++ suffix, L.length prefix + 1) - --- | Show a screenful of the high scores table. --- Parameter height is the number of (3-line) scores to be shown. -showTable :: ScoreTable -> Int -> Int -> String -showTable h start height = - let zipped = zip [1..] h - screenful = take height . drop (start - 1) $ zipped - in - L.concatMap showScore screenful - --- | Produces a couple of renderings of the high scores table. -slideshow :: Int -> ScoreTable -> Int -> [String] -slideshow pos h height = - if pos <= height - then [showTable h 1 height] - else [showTable h 1 height, - showTable h (max (height + 1) (pos - height `div` 2)) height] - --- | Take care of a new score, return a list of messages to display. -register :: Config.CP -> Bool -> ScoreRecord -> IO (String, [String]) -register config write s = - do - h <- restore config - let (h', pos) = insertPos s h - (_, nlines) = normalLevelBound -- TODO: query terminal size instead - height = nlines `div` 3 - (msgCurrent, msgUnless) = - case status s of - Killed _ -> (" short-lived", " (score halved)") - Camping _ -> (" current", " (unless you are slain)") - Victor -> (" glorious", - if pos <= height - then " among the greatest heroes" - else "") - msg = printf "Your%s exploits award you place >> %d <<%s." - msgCurrent pos msgUnless - when write $ save config h' - return (msg, slideshow pos h' height) diff --git a/src/Item.hs b/src/Item.hs deleted file mode 100644 --- a/src/Item.hs +++ /dev/null @@ -1,199 +0,0 @@ -module Item where - -import Data.Binary -import qualified Data.Set as S -import qualified Data.List as L -import qualified Data.Map as M -import Data.Maybe -import Data.Char -import Data.Function -import Data.Ord -import Control.Monad - -import Utils.Assert -import Random -import Content.ItemKind -import qualified Color -import Flavour -import qualified Kind - -data Item = Item - { jkind :: !(Kind.Id ItemKind) - , jpower :: !Int -- TODO: see the TODO about jpower - , jletter :: Maybe Char -- ^ inventory identifier - , jcount :: !Int - } - deriving Show - -instance Binary Item where - put (Item ik ip il ic ) = - put ik >> put ip >> put il >> put ic - get = liftM4 Item get get get get - -type FlavourMap = M.Map (Kind.Id ItemKind) Flavour -- TODO: rewrite and move elsewhere - -type Discoveries = S.Set (Kind.Id ItemKind) - --- | Assigns flavours to item kinds. Assures no flavor is repeated, --- except for items with only one permitted flavour. -rollFlavourMap :: Kind.Id ItemKind -> ItemKind -> - Rnd (FlavourMap, S.Set Flavour) -> - Rnd (FlavourMap, S.Set Flavour) -rollFlavourMap key ik rnd = - let flavours = iflavour ik - in if L.length flavours == 1 - then rnd - else do - (assocs, available) <- rnd - let proper = S.fromList flavours `S.intersection` available - flavour <- oneOf (S.toList proper) - return (M.insert key flavour assocs, S.delete flavour available) - --- | Randomly chooses flavour for all item kinds for this game. -dungeonFlavourMap :: Rnd FlavourMap -dungeonFlavourMap = - liftM fst $ Kind.foldrWithKey rollFlavourMap (return (M.empty, S.fromList stdFlav)) - -getFlavour :: FlavourMap -> Kind.Id ItemKind -> Flavour -getFlavour assocs ik = - let kind = Kind.getKind ik - in case iflavour kind of - [] -> assert `failure` (assocs, ik, kind) - [f] -> f - _:_ -> assocs M.! ik - -fistKindId :: Kind.Id ItemKind -fistKindId = Kind.getId ((== "fist") . iname) - -viewItem :: Kind.Id ItemKind -> FlavourMap -> (Char, Color.Color) -viewItem ik assocs = (isymbol (Kind.getKind ik), flavourToColor $ getFlavour assocs ik) - -itemLetter :: ItemKind -> Maybe Char -itemLetter ik = if isymbol ik == '$' then Just '$' else Nothing - --- | Generate an item. -newItem :: Int -> Rnd Item -newItem lvl = do - (ikChosen, kind) <- frequency Kind.frequency - count <- rollQuad lvl (icount kind) - if count == 0 - then newItem lvl -- Rare item; beware of inifite loops. - else do - power <- rollQuad lvl (ipower kind) - return $ Item ikChosen power (itemLetter kind) count - --- | Assigns a letter to an item, for inclusion --- in the inventory of a hero. Takes a remembered --- letter and a starting letter. -assignLetter :: Maybe Char -> Char -> [Item] -> Maybe Char -assignLetter r c is = - case r of - Just l | l `L.elem` allowed -> Just l - _ -> listToMaybe free - where - current = S.fromList (mapMaybe jletter is) - allLetters = ['a'..'z'] ++ ['A'..'Z'] - candidates = take (length allLetters) $ - drop (fromJust (L.findIndex (==c) allLetters)) $ - cycle allLetters - free = L.filter (\x -> not (x `S.member` current)) candidates - allowed = '$' : free - -cmpLetter :: Char -> Char -> Ordering -cmpLetter x y = compare (isUpper x, toLower x) (isUpper y, toLower y) - -cmpLetter' :: Maybe Char -> Maybe Char -> Ordering -cmpLetter' Nothing Nothing = EQ -cmpLetter' Nothing (Just _) = GT -cmpLetter' (Just _) Nothing = LT -cmpLetter' (Just l) (Just l') = cmpLetter l l' - -maxBy :: (a -> a -> Ordering) -> a -> a -> a -maxBy cmp x y = case cmp x y of - LT -> y - _ -> x - -maxLetter :: Char -> Char -> Char -maxLetter = maxBy cmpLetter - -mergeLetter :: Maybe Char -> Maybe Char -> Maybe Char -mergeLetter = mplus - -letterRange :: [Char] -> String -letterRange ls = sectionBy (L.sortBy cmpLetter ls) Nothing - where - succLetter c d = ord d - ord c == 1 - - sectionBy [] Nothing = "" - sectionBy [] (Just (c,d)) = finish (c,d) - sectionBy (x:xs) Nothing = sectionBy xs (Just (x,x)) - sectionBy (x:xs) (Just (c,d)) - | succLetter d x = sectionBy xs (Just (c,x)) - | otherwise = finish (c,d) ++ sectionBy xs (Just (x,x)) - - finish (c,d) | c == d = [c] - | succLetter c d = [c,d] - | otherwise = [c,'-',d] - -letterLabel :: Maybe Char -> String -letterLabel Nothing = " " -letterLabel (Just c) = c : " - " - --- | Adds an item to a list of items, joining equal items. --- Also returns the joined item. --- TODO: the resulting list can contain items with the same letter. --- TODO: name [Item] Inventory and have some invariants, e.g. no equal letters. -joinItem :: Item -> [Item] -> (Item, [Item]) -joinItem i is = - case findItem (equalItemIdentity i) is of - Nothing -> (i, i : is) - Just (j,js) -> let n = i { jcount = jcount i + jcount j, - jletter = mergeLetter (jletter j) (jletter i) } - in (n, n : js) - --- | Removes an item from a list of items. --- Takes an equality function (i.e., by letter or ny kind) as an argument. -removeItemBy :: (Item -> Item -> Bool) -> Item -> [Item] -> [Item] -removeItemBy eq i = concatMap $ \ x -> - if eq i x - then let remaining = jcount x - jcount i - in if remaining > 0 - then [x { jcount = remaining }] - else [] - else [x] - -equalItemIdentity :: Item -> Item -> Bool -equalItemIdentity i1 i2 = jpower i1 == jpower i2 && jkind i1 == jkind i2 - -removeItemByIdentity :: Item -> [Item] -> [Item] -removeItemByIdentity = removeItemBy equalItemIdentity - -equalItemLetter :: Item -> Item -> Bool -equalItemLetter = (==) `on` jletter - -removeItemByLetter :: Item -> [Item] -> [Item] -removeItemByLetter = removeItemBy equalItemLetter - --- | Finds an item in a list of items. -findItem :: (Item -> Bool) -> [Item] -> Maybe (Item, [Item]) -findItem p = findItem' [] - where - findItem' _ [] = Nothing - findItem' acc (i:is) - | p i = Just (i, reverse acc ++ is) - | otherwise = findItem' (i:acc) is - -strongestItem :: [Item] -> String -> Maybe Item -strongestItem is groupName = - let cmp = comparing jpower - igs = L.filter (\ i -> iname (Kind.getKind (jkind i)) == groupName) is - in case igs of - [] -> Nothing - _ -> Just $ L.maximumBy cmp igs - -itemPrice :: Item -> Int -itemPrice i = - case iname (Kind.getKind (jkind i)) of - "gold piece" -> jcount i - "gem" -> jcount i * 100 - _ -> 0 diff --git a/src/ItemAction.hs b/src/ItemAction.hs deleted file mode 100644 --- a/src/ItemAction.hs +++ /dev/null @@ -1,318 +0,0 @@ -module ItemAction where - -import Control.Monad -import Control.Monad.State hiding (State, state) -import qualified Data.List as L -import qualified Data.IntMap as IM -import Data.Maybe -import qualified Data.Set as S - -import Utils.Assert -import Action -import Display hiding (display) -import Loc -import Grammar -import Item -import Content.ItemKind -import qualified Keys as K -import Level -import Actor -import ActorState -import ActorAdd -import Perception -import State -import EffectAction -import qualified Kind - --- Item UI code with the Action type and everything it depends on --- that is not already in Action.hs and EffectAction.hs. --- This file should not depend on Action.hs. - --- | Display inventory -inventory :: Action a -inventory = do - items <- gets (bitems . getPlayerBody) - if L.null items - then abortWith "Not carrying anything." - else do - displayItems "Carrying:" True items - session getConfirm - abortWith "" - --- | Let the player choose any item with a given group name. --- Note that this does not guarantee an item from the group to be chosen, --- as the player can override the choice. --- TODO: There should be a datatype for item groups instead of strings --- or perhaps the functionality should be implemented differently, --- e.g., based on equipment slot, as soon as it's specified for item kinds. -getGroupItem :: [Item] -> -- all objects in question - String -> -- name of the group - String -> -- prompt - String -> -- how to refer to the collection of objects - Action (Maybe Item) -getGroupItem is groupName prompt packName = - let choice i = groupName == iname (Kind.getKind (jkind i)) - header = capitalize $ suffixS groupName - in getItem prompt choice header is packName - -applyGroupItem :: ActorId -> -- actor applying the item; on current level - String -> -- how the "applying" is called - Item -> -- the item to be applied - Action () -applyGroupItem actor verb item = do - state <- get - body <- gets (getActor actor) - per <- currentPerception - -- only one item consumed, even if several in inventory - let consumed = item { jcount = 1 } - msg = subjectVerbIObject state body verb consumed "" - loc = bloc body - removeFromInventory actor consumed loc - when (loc `S.member` ptvisible per) $ messageAdd msg - itemEffectAction 5 actor actor consumed - advanceTime actor - -playerApplyGroupItem :: String -> Action () -playerApplyGroupItem groupName = do - is <- gets (bitems . getPlayerBody) - iOpt <- getGroupItem is groupName - ("What to " ++ applyToVerb groupName ++ "?") "in inventory" - pl <- gets splayer - case iOpt of - Just i -> - let verb = applyToVerb (iname (Kind.getKind (jkind i))) - in applyGroupItem pl verb i - Nothing -> neverMind True - -applyToVerb :: String -> String -applyToVerb "potion" = "quaff" -applyToVerb "scroll" = "read" -applyToVerb _ = "destructively apply" - -quaffPotion :: Action () -quaffPotion = playerApplyGroupItem "potion" - -readScroll :: Action () -readScroll = playerApplyGroupItem "scroll" - -zapGroupItem :: ActorId -> -- actor zapping the item; on current level - Loc -> -- target location for the zapping - String -> -- how the "zapping" is called - Item -> -- the item to be zapped - Action () -zapGroupItem source loc verb item = do - state <- get - sm <- gets (getActor source) - per <- currentPerception - let consumed = item { jcount = 1 } - sloc = bloc sm - subject = - if sloc `S.member` ptvisible per - then sm - else template Actor.heroKindId (Just "somebody") Nothing 99 sloc - msg = subjectVerbIObject state subject verb consumed "" - removeFromInventory source consumed sloc - case locToActor loc state of - Just ta -> do - -- The message describes the source part of the action. - when (sloc `S.member` ptvisible per || isAHero ta) $ messageAdd msg - -- Messages inside itemEffectAction describe the target part. - b <- itemEffectAction 10 source ta consumed - unless b $ modify (updateLevel (dropItemsAt [consumed] loc)) - Nothing -> do - when (sloc `S.member` ptvisible per) $ messageAdd msg - modify (updateLevel (dropItemsAt [consumed] loc)) - advanceTime source - -playerZapGroupItem :: String -> Action () -playerZapGroupItem groupName = do - state <- get - is <- gets (bitems . getPlayerBody) - iOpt <- getGroupItem is groupName - ("What to " ++ zapToVerb groupName ++ "?") "in inventory" - pl <- gets splayer - per <- currentPerception - case iOpt of - Just i -> - case targetToLoc (ptvisible per) state of - Nothing -> abortWith "target invalid" - Just loc -> - -- TODO: draw digital line and see if obstacles prevent firing - if actorReachesLoc pl loc per (Just pl) - then let verb = zapToVerb (iname (Kind.getKind (jkind i))) - in zapGroupItem pl loc verb i - else abortWith "target not reachable" - Nothing -> neverMind True - -zapToVerb :: String -> String -zapToVerb "wand" = "aim" -zapToVerb "dart" = "throw" -zapToVerb _ = "furiously zap" - -aimItem :: Action () -aimItem = playerZapGroupItem "wand" - -throwItem :: Action () -throwItem = playerZapGroupItem "dart" - --- | Drop a single item. --- TODO: allow dropping a given number of identical items. -dropItem :: Action () -dropItem = do - pl <- gets splayer - state <- get - pbody <- gets getPlayerBody - ploc <- gets (bloc . getPlayerBody) - items <- gets (bitems . getPlayerBody) - iOpt <- getAnyItem "What to drop?" items "inventory" - case iOpt of - Just stack -> do - let i = stack { jcount = 1 } - removeOnlyFromInventory pl i (bloc pbody) - messageAdd (subjectVerbIObject state pbody "drop" i "") - modify (updateLevel (dropItemsAt [i] ploc)) - Nothing -> neverMind True - playerAdvanceTime - --- TODO: this is a hack for dropItem, because removeFromInventory --- makes it impossible to drop items if the floor not empty. -removeOnlyFromInventory :: ActorId -> Item -> Loc -> Action () -removeOnlyFromInventory actor i _loc = - updateAnyActor actor (\ m -> m { bitems = removeItemByLetter i (bitems m) }) - --- | Remove given item from an actor's inventory or floor. --- TODO: this is subtly wrong: if identical items are on the floor and in --- inventory, the floor one will be chosen, regardless of player intention. --- TODO: right now it ugly hacks (with the ploc) around removing items --- of dead heros/monsters. The subtle incorrectness helps here a lot, --- because items of dead heroes land on the floor, so we use them up --- in inventory, but remove them after use from the floor. -removeFromInventory :: ActorId -> Item -> Loc -> Action () -removeFromInventory actor i loc = do - b <- removeFromLoc i loc - unless b $ - updateAnyActor actor (\ m -> m { bitems = removeItemByLetter i (bitems m) }) - --- | Remove given item from the given location. Tell if successful. -removeFromLoc :: Item -> Loc -> Action Bool -removeFromLoc i loc = do - lvl <- gets slevel - if not $ L.any (equalItemIdentity i) (lvl `iat` loc) - then return False - else - modify (updateLevel (updateIMap adj)) >> - return True - where - rib Nothing = assert `failure` (i, loc) - rib (Just (is, irs)) = - case (removeItemByIdentity i is, irs) of - ([], []) -> Nothing - iss -> Just iss - adj = IM.alter rib loc - -actorPickupItem :: ActorId -> Action () -actorPickupItem actor = do - state <- get - pl <- gets splayer - per <- currentPerception - lvl <- gets slevel - body <- gets (getActor actor) - let loc = bloc body - perceived = loc `S.member` ptvisible per - isPlayer = actor == pl - -- check if something is here to pick up - case lvl `iat` loc of - [] -> abortIfWith isPlayer "nothing here" - i:is -> -- pick up first item; TODO: let player select item; not for monsters - case assignLetter (jletter i) (bletter body) (bitems body) of - Just l -> do - let (ni, nitems) = joinItem (i { jletter = Just l }) (bitems body) - -- message depends on who picks up and if a hero can perceive it - if isPlayer - then messageAdd (letterLabel (jletter ni) ++ objectItem state ni) - else when perceived $ - messageAdd $ subjCompoundVerbIObj state body "pick" "up" i "" - removeFromLoc i loc - >>= assert `trueM` (i, is, loc, "item is stuck") - -- add item to actor's inventory: - updateAnyActor actor $ \ m -> - m { bitems = nitems, bletter = maxLetter l (bletter body) } - Nothing -> abortIfWith isPlayer "cannot carry any more" - advanceTime actor - -pickupItem :: Action () -pickupItem = do - pl <- gets splayer - actorPickupItem pl - --- TODO: I think that player handlers should be wrappers --- around more general actor handlers, but --- the actor handlers should be performing --- specific actions, i.e., already specify the item to be --- picked up. It doesn't make sense to invoke dialogues --- for arbitrary actors, and most likely the --- decision for a monster is based on perceiving --- a particular item to be present, so it's already --- known. In actor handlers we should make sure --- that messages are printed to the player only if the --- hero can perceive the action. --- Perhaps this means half of this code should be split and moved --- to ItemState, to be independent of any IO code from Action/Display. Actually, not, since the message display depends on Display. Unless we return a string to be displayed. - --- | Let the player choose any item from a list of items. --- TODO: you can drop an item on the floor, which works correctly, --- but is weird and useless. -getAnyItem :: String -> -- prompt - [Item] -> -- all objects in question - String -> -- how to refer to the collection of objects - Action (Maybe Item) -getAnyItem prompt = getItem prompt (const True) "Objects" - --- | Let the player choose a single item from a list of items. -getItem :: String -> -- prompt message - (Item -> Bool) -> -- which items to consider suitable - String -> -- how to describe suitable objects - [Item] -> -- all objects in question - String -> -- how to refer to the collection of objects - Action (Maybe Item) -getItem prompt p ptext is0 isn = do - lvl <- gets slevel - body <- gets getPlayerBody - let loc = bloc body - tis = lvl `iat` loc - floorMsg = if L.null tis then "" else " -," - is = L.filter p is0 - choice = if L.null is - then "[*," ++ floorMsg ++ " ESC]" - else let r = letterRange $ mapMaybe jletter is - in "[" ++ r ++ ", ?, *," ++ floorMsg ++ " RET, ESC]" - ask = do - when (L.null is0 && L.null tis) $ - abortWith "Not carrying anything." - messageReset (prompt ++ " " ++ choice) - display - session nextCommand >>= perform - perform command = do - messageClear - case command of - K.Char '?' -> do - -- filter for supposedly suitable objects - b <- displayItems (ptext ++ " " ++ isn) True is - if b then session (getOptionalConfirm (const ask) perform) - else ask - K.Char '*' -> do - -- show all objects - b <- displayItems ("Objects " ++ isn) True is0 - if b then session (getOptionalConfirm (const ask) perform) - else ask - K.Char '-' -> - case tis of - [] -> return Nothing - i:_rs -> -- use first item; TODO: let player select item - return $ Just i - K.Char l -> - return (L.find (maybe False (== l) . jletter) is0) - K.Return -> -- TODO: it should be the first displayed (except $) - return (case is of [] -> Nothing ; i : _ -> Just i) - _ -> return Nothing - ask diff --git a/src/Keybindings.hs b/src/Keybindings.hs deleted file mode 100644 --- a/src/Keybindings.hs +++ /dev/null @@ -1,81 +0,0 @@ -module Keybindings where - -import qualified Data.Map as M -import qualified Data.List as L - -import Utils.Assert -import Action -import Command -import Geometry -import qualified Keys as K - --- | Keybindings. -data Keybindings = Keybindings - { kdir :: DirCommand - , kudir :: DirCommand - , kother :: M.Map K.Key Command - } - -handleKey :: X -> Keybindings -> K.Key -> Action () -handleKey lxsize kb k = - K.handleDirection lxsize k (caction $ kdir kb) $ - K.handleUDirection lxsize k (caction $ kudir kb) $ - case M.lookup k (kother kb) of - Just c -> caction c - Nothing -> abortWith $ "unknown command (" ++ K.showKey k ++ ")" - -keyHelp :: (K.Key -> [K.Key]) -> Keybindings -> String -keyHelp aliases kb = - let - fmt k h = replicate 15 ' ' ++ k ++ replicate ((13 - length k) `max` 1) ' ' - ++ h ++ replicate ((35 - length h) `max` 1) ' ' - fmts s = replicate 2 ' ' ++ s ++ replicate ((71 - length s) `max` 1) ' ' - blank = fmt "" "" - movKs = - [ "" - , "You move throughout the level using the numerical keypad or" - , "the vi text editor keys (also known as \"Rogue-like keys\")." - , "" - , " 7 8 9 y k u" - , " \\|/ \\|/" - , " 4-5-6 h-.-l" - , " /|\\ /|\\" - , " 1 2 3 b j n" - , "" - , "Shift and a movement key make the hero run in the indicated direction," - , "until anything of interest is spotted. '5' and '.' skip a turn." - , "" - , "To search, open or attack, bump into walls, doors or monsters." - , "" - , "For more playing instructions see file PLAYING.md." - , "" - , "Press space to see the next page." - , "" - , "" - ] - mov = map fmts movKs - keyC = fmt "keys" "command" --- footer = --- fmts "(To search, open or attack, bump into walls, doors or monsters.)" - disp k = L.concatMap show $ aliases k - rest = [ fmt (disp k) h - | (k, Described h _) <- M.toAscList (kother kb) ] - in - unlines ([blank] ++ mov ++ [blank, keyC] ++ rest) --- [blank, footer, blank]) - --- | Maps a key to the canonical key for the command it denotes. --- Takes into account the keypad and any macros from a config file. --- Macros cannot depend on each other, but they can on canonMoveKey. --- This has to be fully evaluated to catch errors in macro definitions early. -macroKey :: [(String, String)] -> M.Map K.Key K.Key -macroKey section = - let trans k = case K.keyTranslate k of - K.Unknown s -> assert `failure` ("unknown macro key " ++ s) - kt -> kt - trMacro (from, to) = let fromTr = trans from - !toTr = K.canonMoveKey $ trans to - in if fromTr == toTr - then assert `failure` ("degenerate alias", toTr) - else (fromTr, toTr) - in M.fromList $ L.map trMacro section diff --git a/src/Keys.hs b/src/Keys.hs deleted file mode 100644 --- a/src/Keys.hs +++ /dev/null @@ -1,120 +0,0 @@ -module Keys where - -import Prelude hiding (Left, Right) -import qualified Data.Map as M -import qualified Data.List as L -import Data.Char -import Data.Maybe - -import Geometry -import Dir - --- TODO: if the file grows much larger, split it and move a part to Utils/ - --- | Frontend-independent datatype to represent keys. -data Key = - Esc - | Return - | Tab - | PgUp - | PgDn - | Left - | Right - | Up - | Down - | End - | Begin - | Home - | KP !Char -- ^ a keypad key for a character (digits and operators) - | Char !Char -- ^ a single printable character - | Unknown !String -- ^ an unknown key, collected to warn the user later - deriving (Ord, Eq) - -showKey :: Key -> String -showKey (Char ' ') = "" -- warnings about "command ( )" look wrong -showKey (Char c) = [c] -showKey Esc = "ESC" -- these three are common and terse abbreviations -showKey Return = "RET" -showKey Tab = "TAB" -showKey PgUp = "" -showKey PgDn = "" -showKey Left = "" -showKey Right = "" -showKey Up = "" -showKey Down = "" -showKey End = "" -showKey Begin = "" -showKey Home = "" -showKey (KP c) = "" -showKey (Unknown s) = s - -instance Show Key where - show = showKey - -dirChars :: [Char] -dirChars = ['y', 'k', 'u', 'l', 'n', 'j', 'b', 'h'] - -dirKeys :: [Key] -dirKeys = map Char dirChars - -dirUKeys :: [Key] -dirUKeys = map (Char . toUpper) dirChars - --- | Maps a keypad movement key to the canonical form. --- Hard-coded not to bloat config files. -canonMoveKey :: Key -> Key -canonMoveKey = - let assocs = (Begin, Char '.') : (KP '5', Char '.') : - zip [Home, Up, PgUp, Right, PgDn, Down, End, Left] dirKeys ++ - zip (map KP ['7', '8', '9', '6', '3', '2', '1', '4']) dirUKeys - m = M.fromList assocs - in \ e -> fromMaybe e (M.lookup e m) - --- | Configurable event handler for the direction keys. Is used to --- handle player moves, but can also be used for directed commands --- such as close door. -handleDirection :: X -> Key -> (Dir -> a) -> a -> a -handleDirection lxsize e h k = - let assocs = zip dirKeys (moves lxsize) - in maybe k h (L.lookup e assocs) - --- | Configurable event handler for the upper direction keys. -handleUDirection :: X -> Key -> (Dir -> a) -> a -> a -handleUDirection lxsize e h k = - let assocs = zip dirUKeys (moves lxsize) - in maybe k h (L.lookup e assocs) - --- | Translate key from a GTK string description to our internal key type. --- To be used, in particular, for the macros in the config file. -keyTranslate :: String -> Key -keyTranslate "less" = Char '<' -keyTranslate "greater" = Char '>' -keyTranslate "period" = Char '.' -keyTranslate "colon" = Char ':' -keyTranslate "comma" = Char ',' -keyTranslate "space" = Char ' ' -keyTranslate "question" = Char '?' -keyTranslate "dollar" = Char '$' -keyTranslate "asterisk" = Char '*' -keyTranslate "KP_Multiply" = Char '*' -keyTranslate "slash" = Char '/' -keyTranslate "KP_Divide" = Char '/' -keyTranslate "underscore" = Char '_' -keyTranslate "minus" = Char '-' -keyTranslate "KP_Subtract" = Char '-' -keyTranslate "Escape" = Esc -keyTranslate "Return" = Return -keyTranslate "Tab" = Tab -keyTranslate "KP_Up" = Up -keyTranslate "KP_Down" = Down -keyTranslate "KP_Left" = Left -keyTranslate "KP_Right" = Right -keyTranslate "KP_Home" = Home -keyTranslate "KP_End" = End -keyTranslate "KP_Page_Up" = PgUp -keyTranslate "KP_Page_Down" = PgDn -keyTranslate "KP_Begin" = Begin -keyTranslate "KP_Enter" = Return -keyTranslate ['K','P','_',c] = KP c -keyTranslate [c] = Char c -keyTranslate s = Unknown s diff --git a/src/Kind.hs b/src/Kind.hs deleted file mode 100644 --- a/src/Kind.hs +++ /dev/null @@ -1,64 +0,0 @@ -module Kind - ( Id, Kind.getKind, getId, frequency, foldrWithKey, boundsId - , Array, (!), (//), listArray, bounds - ) where - -import Data.Binary -import qualified Data.List as L -import qualified Data.IntMap as IM -import qualified Data.Word as Word -import qualified Data.Array.Unboxed as A -import qualified Data.Ix as Ix - -import Utils.Assert -import Content.Content -import Frequency - -newtype Id a = Id{kindId :: Word8} deriving (Show, Eq, Ord, Ix.Ix) - -instance Binary (Id a) where - put (Id i) = put i - get = fmap Id get - -getKind :: Content a => Id a -> a -getKind (Id i) = kindMap IM.! (fromEnum i) - -getId :: Content a => (a -> Bool) -> Id a -getId f = case [Id i | (i, k) <- kindAssocs, f k] of - [i] -> i - l -> assert `failure` l - -frequency :: Content a => Frequency (Id a, a) -frequency = Frequency [(getFreq k, (Id i, k)) | (i, k) <- kindAssocs] - -foldrWithKey :: Content a => (Id a -> a -> b -> b) -> b -> b -foldrWithKey f z = L.foldr (\ (i, a) -> f (Id i) a) z kindAssocs - -limitsId :: Content a => ((Id a, a), (Id a, a)) -limitsId = let (i1, a1) = IM.findMin kindMap - (i2, a2) = IM.findMax kindMap - in ((Id (toEnum i1), a1), (Id (toEnum i2), a2)) - -boundsId :: Content a => (Id a, Id a) -boundsId = (Id 0, (fst . snd) limitsId) - -newtype Array i c = Array{_kindArray :: A.UArray i Word.Word8} deriving Show - --- TODO: save/restore is still too slow, but we are already past --- the point of diminishing returns. A dramatic change would be --- low-level conversion to ByteString and serializing that. -instance (Ix.Ix i, Binary i) => Binary (Array i c) where - put (Array a) = put a - get = fmap Array get - -(!) :: Ix.Ix i => Array i c -> i -> Id c -(!) (Array a) i = Id $ a A.! i - -(//) :: Ix.Ix i => Array i c -> [(i, Id c)] -> Array i c -(//) (Array a) l = Array $ a A.// [(i, kindId e) | (i, e) <- l] - -listArray :: Ix.Ix i => (i, i) -> [Id c] -> Array i c -listArray bds l = Array $ A.listArray bds [(kindId e) | e <- l] - -bounds :: Ix.Ix i => Array i c -> (i, i) -bounds (Array a) = A.bounds a diff --git a/src/Level.hs b/src/Level.hs deleted file mode 100644 --- a/src/Level.hs +++ /dev/null @@ -1,167 +0,0 @@ -module Level - ( SmellTime(..), SmellMap, SecretMap - , ItemMap, TileMap, Level(..) - , updateHeroes, updateMonsters, updateLMap, updateLRMap, updateIMap - , updateSmell , emptyParty, at, rememberAt, iat, irememberAt - , accessible, openable, findLoc, findLocTry, dropItemsAt - ) where - -import Data.Binary -import qualified Data.List as L -import qualified Data.IntMap as IM - -import Utils.Assert -import Geometry -import Loc -import Actor -import Item -import Content.TileKind -import Random -import qualified Tile -import qualified Feature as F -import qualified Kind - -newtype SmellTime = SmellTime{smelltime :: Time} deriving Show -instance Binary SmellTime where - put = put . smelltime - get = fmap SmellTime get -type SmellMap = IM.IntMap SmellTime - -type SecretMap = IM.IntMap Tile.SecretStrength - -type ItemMap = IM.IntMap ([Item], [Item]) - -type TileMap = Kind.Array Loc TileKind - -data Level = Level - { lheroes :: Party -- ^ all heroes on the level - , lxsize :: X - , lysize :: Y - , lmonsters :: Party -- ^ all monsters on the level - , lsmell :: SmellMap - , lsecret :: SecretMap - , litem :: ItemMap - , lmap :: TileMap - , lrmap :: TileMap - , lmeta :: String - , lstairs :: (Loc, Loc) -- ^ here the stairs (down, up) from other levels end - } - deriving Show - -updateLMap :: (TileMap -> TileMap) -> Level -> Level -updateLMap f lvl = lvl { lmap = f (lmap lvl) } - -updateLRMap :: (TileMap -> TileMap) -> Level -> Level -updateLRMap f lvl = lvl { lrmap = f (lrmap lvl) } - -updateIMap :: (IM.IntMap ([Item], [Item]) -> - IM.IntMap ([Item], [Item])) -> Level - -> Level -updateIMap f lvl = lvl { litem = f (litem lvl) } - -updateSmell :: (SmellMap -> SmellMap) -> Level -> Level -updateSmell f lvl = lvl { lsmell = f (lsmell lvl) } - -updateMonsters :: (Party -> Party) -> Level -> Level -updateMonsters f lvl = lvl { lmonsters = f (lmonsters lvl) } - -updateHeroes :: (Party -> Party) -> Level -> Level -updateHeroes f lvl = lvl { lheroes = f (lheroes lvl) } - -emptyParty :: Party -emptyParty = IM.empty - -instance Binary Level where - put (Level hs sx sy ms ls le li lm lrm lme lstairs) = - do - put hs - put sx - put sy - put ms - put ls - put le - put (assert - (IM.null (IM.filter (\ (is1, is2) -> - L.null is1 && L.null is2) li) - `blame` li) li) - put lm - put lrm - put lme - put lstairs - get = do - hs <- get - sx <- get - sy <- get - ms <- get - ls <- get - le <- get - li <- get - lm <- get - lrm <- get - lme <- get - lstairs <- get - return (Level hs sx sy ms ls le li lm lrm lme lstairs) - -at, rememberAt :: Level -> Loc -> (Kind.Id TileKind) -at l p = lmap l Kind.! p -rememberAt l p = lrmap l Kind.! p - --- Note: representations with 2 maps leads to longer code and slower 'remember'. -iat, irememberAt :: Level -> Loc -> [Item] -iat l p = fst $ IM.findWithDefault ([], []) p (litem l) -irememberAt l p = snd $ IM.findWithDefault ([], []) p (litem l) - --- Check whether one location is accessible from the other. --- Precondition: the two locations are next to each other. --- Currently only implements that the target location has to be open. --- TODO: in the future check flying for chasms, swimming for water, etc. -accessible :: Level -> Loc -> Loc -> Bool -accessible lvl _source target = - let tgt = lvl `at` target - in Tile.isWalkable tgt - --- check whether the location contains a door of secrecy level lower than k -openable :: Level -> Tile.SecretStrength -> Loc -> Bool -openable lvl k target = - let le = lsecret lvl - tgt = lvl `at` target - in Tile.hasFeature F.Openable tgt || - (Tile.hasFeature F.Hidden tgt && - le IM.! target < k) - --- Do not scatter items around, it's too much work for the player. -dropItemsAt :: [Item] -> Loc -> Level -> Level -dropItemsAt [] _loc = id -dropItemsAt items loc = - let joinItems = L.foldl' (\ acc i -> snd (joinItem i acc)) - adj Nothing = Just (items, []) - adj (Just (i, ri)) = Just (joinItems items i, ri) - in updateIMap (IM.alter adj loc) - -findLoc :: TileMap -> (Loc -> (Kind.Id TileKind) -> Bool) -> Rnd Loc -findLoc lmap p = - let search = do - loc <- randomR $ Kind.bounds lmap - let tile = lmap Kind.! loc - if p loc tile - then return loc - else search - in search - -findLocTry :: - Int -> -- try to pTry only so many times - TileMap -> - (Loc -> Kind.Id TileKind -> Bool) -> -- loop until satisfied - (Loc -> Kind.Id TileKind -> Bool) -> -- only try to satisfy k times - Rnd Loc -findLocTry numTries lmap p pTry = - let search k = do - loc <- randomR $ Kind.bounds lmap - let tile = lmap Kind.! loc - if p loc tile && pTry loc tile - then return loc - else if k > 1 - then search (k - 1) - else findLoc lmap p - in assert (numTries > 0) $ - search numTries diff --git a/src/LevelState.hs b/src/LevelState.hs deleted file mode 100644 --- a/src/LevelState.hs +++ /dev/null @@ -1,31 +0,0 @@ -module LevelState where - -import Level -import State -import Grammar -import Loc -import Content.TileKind -import qualified Kind - --- | Produces a textual description of the terrain and items at an already --- explored location. Mute for unknown locations. --- The "detailed" variant is for use in the targeting mode. -lookAt :: Bool -> Bool -> State -> Level -> Loc -> String -> String -lookAt detailed canSee s lvl loc msg - | detailed = - let tile = lvl `rememberAt` loc - name = tname . Kind.getKind $ tile - in name ++ " " ++ msg ++ isd - | otherwise = msg ++ isd - where - is = lvl `irememberAt` loc - prefixSee = if canSee then "You see " else "You remember " - prefixThere = if canSee - then "There are several objects here" - else "You remember several objects here" - isd = case is of - [] -> "" - [i] -> prefixSee ++ objectItem s i ++ "." - [i,j] -> prefixSee ++ objectItem s i ++ " and " - ++ objectItem s j ++ "." - _ -> prefixThere ++ if detailed then ":" else "." diff --git a/src/Loc.hs b/src/Loc.hs deleted file mode 100644 --- a/src/Loc.hs +++ /dev/null @@ -1,58 +0,0 @@ -module Loc - ( Loc, toLoc, fromLoc, trLoc, zeroLoc, distance, adjacent, surroundings ) - where - -import Geometry -import Utils.Assert - --- Loc is a positivie integer for speed and to enforce the use of wrappers --- (we don't want newtype to avoid the trouble with using EnumMap --- in place of IntMap, etc.). We represent the screen as a linear framebuffer, --- when Loc is an Int offset counted from the first cell. --- We do bounds check for the X size ASAP and each subsequent --- array access performs another check, effectively for Y size. --- After dungeon is generated (using (X, Y) points, not Loc), Locs are used --- mainly as keys and not constructed often, so the performance will improve --- due to smaller save files, IntMaps and cheaper array indexing, --- including cheaper bounds checks. -type Loc = Int - -toLoc :: X -> (X, Y) -> Loc -toLoc lxsize (x, y) = - assert (lxsize > x && x >= 0 && y >= 0 `blame` (lxsize, x, y)) $ - x + y * lxsize - -fromLoc :: X -> Loc -> (X, Y) -fromLoc lxsize loc = - assert (loc >= 0 `blame` (lxsize, loc)) $ - (loc `rem` lxsize, loc `quot` lxsize) - --- | Translation by a vector, where dx and dy can be negative. -trLoc :: X -> Loc -> (X, Y) -> Loc -trLoc lxsize loc (dx, dy) = - assert (loc >= 0 && res >= 0 `blame` (lxsize, loc, (dx, dy))) $ - res - where res = loc + dx + dy * lxsize - -zeroLoc :: Loc -zeroLoc = 0 - --- | The distance between two points in the metric with diagonal moves. -distance :: X -> Loc -> Loc -> Int -distance lxsize loc0 loc1 - | (x0, y0) <- fromLoc lxsize loc0, (x1, y1) <- fromLoc lxsize loc1 = - lenXY (x1 - x0, y1 - y0) - --- | Return whether two locations are adjacent on the map --- (horizontally, vertically or diagonally). --- A position is also considered adjacent to itself. -adjacent :: X -> Loc -> Loc -> Bool -adjacent lxsize s t = distance lxsize s t <= 1 - --- | Return the 8, or less, surrounding locations of a given location. -surroundings :: X -> Y -> Loc -> [Loc] -surroundings lxsize lysize loc | (x, y) <- fromLoc lxsize loc = - [ toLoc lxsize (x + dx, y + dy) - | (dx, dy) <- movesXY, - x + dx >= 0 && x + dx < lxsize && - y + dy >= 0 && y + dy < lysize ] diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -1,68 +1,64 @@ -module Main where +-- Copyright (c) 2008--2011 Andres Loeh, 2010--2012 Mikolaj Konarski +-- This file is a part of the computer game Allure of the Stars +-- and is released under the terms of the GNU Affero General Public License. +-- For license and copyright information, see the file LICENSE. +-- +-- | The main code file of Allure of the Stairs. Here the knot of engine +-- code pieces and the Allure-specific content defintions is tied, +-- resulting in an executable game. +module Main ( main ) where -import System.Directory -import qualified System.Random as R -import qualified Control.Monad.State as MState +import Data.Maybe -import Action -import State -import DungeonState -import qualified Display -import qualified Save -import Turn -import qualified Config -import ActorAdd -import Item -import qualified Keybindings as KB +import qualified Game.LambdaHack.Display as Display +import qualified Game.LambdaHack.Kind as Kind +import qualified Content.ActorKind +import qualified Content.CaveKind +import qualified Content.ItemKind +import qualified Content.PlaceKind +import qualified Content.RuleKind +import qualified Content.TileKind +import qualified Game.LambdaHack.Start as Start +import Game.LambdaHack.Command +import Game.LambdaHack.Display +import qualified Game.LambdaHack.Config as Config +import Game.LambdaHack.Action +import qualified Game.LambdaHack.BindingAction as BindingAction -main :: IO () -main = Display.startup start +import qualified ConfigDefault --- | Either restore a saved game, or setup a new game. -start :: Display.InternalSession -> IO () -start internalSession = do - config <- Config.config - let section = Config.getItems config "macros" - !macros = KB.macroKey section - sess = (internalSession, macros) - -- check if we have a savegame - f <- Save.file config - b <- doesFileExist f - restored <- if b - then do - Display.displayBlankConfirm sess "Restoring save game" - Save.restoreGame config - else return $ Right "Welcome to Allure of the Stars!" -- new game - case restored of - Right msg -> do - -- TODO: move somewhere sane - (dg, configD) <- - case Config.getOption config "engine" "dungeonRandomGenerator" of - Just sg -> - return (read sg, config) - Nothing -> do - -- Pick the randomly chosen dungeon generator from the IO monad - -- and record it in the config for debugging (can be 'D'umped). - g <- R.getStdGen - let gs = show g - c = Config.set config "engine" "dungeonRandomGenerator" gs - return (g, c) - let ((ploc, lid, dng), ag) = MState.runState (generate configD) dg - sflavour = MState.evalState dungeonFlavourMap ag - (sg, sconfig) <- - case Config.getOption configD "engine" "startingRandomGenerator" of - Just sg -> - return (read sg, configD) - Nothing -> do - -- Pick the randomly chosen starting generator from the IO monad - -- and record it in the config for debugging (can be 'D'umped). - g <- R.getStdGen - let gs = show g - c = Config.set configD "engine" "startingRandomGenerator" gs - return (g, c) - let defState = defaultState dng lid ploc sg - state = defState{sconfig, sflavour} - hstate = initialHeroes ploc state - handlerToIO sess hstate msg handle - Left state -> - handlerToIO sess state "Welcome back to Allure of the Stars." handle +-- | Gather together the content and verify its consistency. +cops :: Kind.COps +cops = Kind.COps + { coactor = Kind.createOps Content.ActorKind.cdefs + , cocave = Kind.createOps Content.CaveKind.cdefs + , coitem = Kind.createOps Content.ItemKind.cdefs + , coplace = Kind.createOps Content.PlaceKind.cdefs + , corule = Kind.createOps Content.RuleKind.cdefs + , cotile = Kind.createOps Content.TileKind.cdefs + } + +-- | Wire together config, content and the definitions of game commands +-- to form the starting game session. Evaluate to check for errors. +sess :: Config.CP -> FrontendSession -> Session +sess config sfs = + let !skeyb = BindingAction.stdBinding config cmdSemantics cmdDescription + !scops = cops + in Session{..} + +-- | Create the starting game config from the default config file +-- and initialize the engine with the starting session. +start :: IO (String, FrontendSession -> IO ()) +start = do + config <- Config.mkConfig ConfigDefault.configDefault + -- The only option taken not from conif in savegame, but from fresh config. + let configFont = fromMaybe "" $ Config.getOption config "ui" "font" + return (configFont, Start.start config . sess config) + +-- | Fire up the frontend with the engine fueled by config and content. +-- Which of the frontends is run depends on the flags supplied +-- when compiling the engine library. +main :: IO () +main = do + (configFont, loop) <- start + Display.startup configFont loop diff --git a/src/Message.hs b/src/Message.hs deleted file mode 100644 --- a/src/Message.hs +++ /dev/null @@ -1,32 +0,0 @@ -module Message where - -import qualified Data.List as L -import Data.Char - -type Message = String - -more :: Message -more = " --more-- " - -yesno :: Message -yesno = " [yn]" - -addMsg :: Message -> Message -> Message -addMsg [] x = x -addMsg xs [] = xs -addMsg xs x = xs ++ " " ++ x - -splitMsg :: Int -> Message -> [String] -splitMsg w xs - | w <= m = [xs] -- border case, we cannot make progress - | l <= w = [xs] -- no problem, everything fits - | otherwise = - let (pre, post) = splitAt (w - m) xs - (ppre, ppost) = break (`L.elem` " .,:!;") $ reverse pre - rpost = dropWhile isSpace ppost - in if L.null rpost - then pre : splitMsg w post - else reverse rpost : splitMsg w (reverse ppre ++ post) - where - m = length more - l = length xs diff --git a/src/Multiline.hs b/src/Multiline.hs new file mode 100644 --- /dev/null +++ b/src/Multiline.hs @@ -0,0 +1,15 @@ +-- Copyright (c) 2008--2011 Andres Loeh, 2010--2012 Mikolaj Konarski +-- This file is a part of the computer game Allure of the Stars +-- and is released under the terms of the GNU Affero General Public License. +-- For license and copyright information, see the file LICENSE. +-- +-- | Template Haskell machinery for quoting multiline strings. +module Multiline (multiline) where + +import qualified Language.Haskell.TH as TH +import qualified Language.Haskell.TH.Quote as TQ + +-- | Handle multiline verbatim string expressions. +multiline :: TQ.QuasiQuoter +multiline = TQ.QuasiQuoter (\x -> (TH.litE . TH.stringL) x) + undefined undefined undefined diff --git a/src/Perception.hs b/src/Perception.hs deleted file mode 100644 --- a/src/Perception.hs +++ /dev/null @@ -1,125 +0,0 @@ -module Perception where - -import qualified Data.Set as S -import qualified Data.List as L -import qualified Data.IntMap as IM -import Data.Maybe -import Control.Monad - -import Loc -import State -import Level -import Actor -import ActorState -import Content.ActorKind -import FOV -import qualified Config -import qualified Tile -import qualified Kind - -data Perception = Perception - { preachable :: S.Set Loc - , pvisible :: S.Set Loc - } - --- The pplayer field is void if player not on the current level, --- or if the player controls a blind monster. Right now, the field is used only --- for player-controlled monsters on the current level. -data Perceptions = Perceptions - { pplayer :: Maybe Perception - , pheroes :: IM.IntMap Perception - , ptotal :: Perception - } - -ptreachable, ptvisible :: Perceptions -> S.Set Loc -ptreachable = preachable . ptotal -ptvisible = pvisible . ptotal - -actorPrLoc :: (Perception -> S.Set Loc) -> - ActorId -> Loc -> Perceptions -> Maybe ActorId -> Bool -actorPrLoc projection actor loc per pl = - let tryHero = case actor of - AMonster _ -> Nothing - AHero i -> do - hper <- IM.lookup i (pheroes per) - return $ loc `S.member` projection hper - tryPl = do -- the case for a monster under player control - guard $ Just actor == pl - pper <- pplayer per - return $ loc `S.member` projection pper - tryAny = tryHero `mplus` tryPl - in fromMaybe False tryAny -- assume not visible, if no perception found - -actorSeesLoc :: ActorId -> Loc -> Perceptions -> Maybe ActorId -> Bool -actorSeesLoc = actorPrLoc pvisible - -actorReachesLoc :: ActorId -> Loc -> Perceptions -> Maybe ActorId -> Bool -actorReachesLoc = actorPrLoc preachable - --- Not quite correct if FOV not symmetric (Shadow). -actorReachesActor :: ActorId -> ActorId -> Loc -> Loc - -> Perceptions -> Maybe ActorId - -> Bool -actorReachesActor actor1 actor2 loc1 loc2 per pl = - actorReachesLoc actor1 loc2 per pl || - actorReachesLoc actor2 loc1 per pl - -perception_ :: State -> Perceptions -perception_ state@(State { splayer = pl, - sconfig = config, - ssensory = sensory }) = - let lvl@Level{lheroes = hs} = slevel state - mode = Config.get config "engine" "fovMode" - radius = let r = Config.get config "engine" "fovRadius" - in if r < 1 - then error $ "FOV radius is " ++ show r ++ ", should be >= 1" - else r - fovMode m = if not $ asight $ Kind.getKind $ bkind m - then Blind - else - -- terrible, temporary hack - case sensory of - Vision 3 -> Digital radius - Vision 2 -> Permissive radius - Vision 1 -> Shadow - _ -> - -- this is not a hack - case mode of - "permissive" -> Permissive radius - "digital" -> Digital radius - "shadow" -> Shadow - _ -> error $ "Unknown FOV mode: " ++ show mode - - -- Perception for a player-controlled monster on the current level. - pper = if isAMonster pl && memActor pl state - then let m = getPlayerBody state - in Just $ perception (fovMode m) (bloc m) lvl - else Nothing - pers = IM.map (\ h -> perception (fovMode h) (bloc h) lvl) hs - lpers = maybeToList pper ++ IM.elems pers - reachable = S.unions (L.map preachable lpers) - visible = S.unions (L.map pvisible lpers) - in Perceptions { pplayer = pper, - pheroes = pers, - ptotal = Perception reachable visible } - --- | Once we compute the reachable fields using FOV, it is possible --- to compute what the hero can actually see. -perception :: FovMode -> Loc -> Level -> Perception -perception fovMode ploc lvl@Level{lxsize, lysize} = - let - -- Reachable are all fields on an unblocked path from the hero position. - -- The player position is visible, but not reachable (e.g. for targeting). - reachable = fullscan fovMode ploc lvl - -- Everybody can see locations that are lit and are reachable. - uniVisible = S.filter (\ loc -> Tile.isLit (lvl `at` loc)) reachable - -- The hero is assumed to carry a light source, too. - litVisible = S.insert ploc uniVisible - -- Reachable fields adjacent to lit fields are visible, too. - adjVisible = - S.filter - (L.any (`S.member` litVisible) . surroundings lxsize lysize) - reachable - -- Visible fields are either lit or adjacent to lit. - visible = S.union litVisible adjVisible - in Perception reachable visible diff --git a/src/Random.hs b/src/Random.hs deleted file mode 100644 --- a/src/Random.hs +++ /dev/null @@ -1,114 +0,0 @@ -module Random - (Rnd, randomR, binaryChoice, chance, - roll, oneOf, frequency, (*~), (~+~), - RollDice, rollDice, maxDice, minDice, meanDice, - RollQuad, rollQuad, intToQuad) - where - -import qualified Data.Binary as Binary -import Data.Ratio -import qualified System.Random as R -import Control.Monad.State - -import Utils.Assert -import Frequency - --- TODO: if the file grows much larger, split it and move a part to Utils/ - -type Rnd a = State R.StdGen a - --- TODO: rewrite; was written in a "portable" way because the implementation of --- State changes between mtl versions 1 and 2. Now we are using only mtl 2. -randomR :: (R.Random a) => (a, a) -> Rnd a -randomR rng = - do - g <- get - let (x, ng) = R.randomR rng g - put ng - return x - -binaryChoice :: a -> a -> Rnd a -binaryChoice p0 p1 = - do - b <- randomR (False,True) - return (if b then p0 else p1) - -chance :: Rational -> Rnd Bool -chance r = - do - let n = numerator r - d = denominator r - k <- randomR (1, d) - return (k <= n) - --- | roll a single die -roll :: Int -> Rnd Int -roll x = if x <= 0 then return 0 else randomR (1,x) - -oneOf :: [a] -> Rnd a -oneOf xs = - do - r <- randomR (0, length xs - 1) - return (xs !! r) - -frequency :: Frequency a -> Rnd a -frequency (Frequency fs) = - do - r <- randomR (1, sum (map fst fs)) - return (frequency' r fs) - where - frequency' :: Int -> [(Int, a)] -> a - frequency' m [] = assert `failure` (map fst fs, m) - frequency' m ((n, x) : xs) - | m <= n = x - | otherwise = frequency' (m - n) xs - --- ** Arithmetic operations on Rnd. - -infixl 7 *~ -infixl 6 ~+~ - -(~+~) :: Num a => Rnd a -> Rnd a -> Rnd a -(~+~) = liftM2 (+) - -(*~) :: Num a => Int -> Rnd a -> Rnd a -x *~ r = liftM sum (replicateM x r) - --- RollDice: 1d7, 3d3, 2d0, etc. (a, b) represent (a *~ roll b). -type RollDice = (Binary.Word8, Binary.Word8) - -rollDice :: RollDice -> Rnd Int -rollDice (a', b') = - let (a, b) = (fromEnum a', fromEnum b') - in a *~ roll b - -maxDice :: RollDice -> Int -maxDice (a', b') = - let (a, b) = (fromEnum a', fromEnum b') - in a * b - -minDice :: RollDice -> Int -minDice (a', b') = - let (a, b) = (fromEnum a', fromEnum b') - in if b == 0 then 0 else a - -meanDice :: RollDice -> Rational -meanDice (a', b') = - let (a, b) = (fromIntegral a', fromIntegral b') - in if b' == 0 then 0 else a * (b + 1) % 2 - --- rollQuad (a, b, x, y) = a *~ roll b + (lvl * (x *~ roll y)) / 10 -type RollQuad = (Binary.Word8, Binary.Word8, Binary.Word8, Binary.Word8) - -rollQuad :: Int -> RollQuad -> Rnd Int -rollQuad lvl (a, b, x, y) = do - aDb <- rollDice (a, b) - xDy <- rollDice (x, y) - return $ aDb + (lvl * xDy) `div` 10 - -intToQuad :: Int -> RollQuad -intToQuad 0 = (0, 0, 0, 0) -intToQuad n = let n' = toEnum n - in if n' > maxBound || n' < minBound - then assert `failure` n - else (n', 1, 0, 0) diff --git a/src/Save.hs b/src/Save.hs deleted file mode 100644 --- a/src/Save.hs +++ /dev/null @@ -1,51 +0,0 @@ -module Save where - -import System.Directory -import qualified Control.Exception as E hiding (handle) - -import Utils.File -import State -import qualified Config - --- | Name of the save game. -file :: Config.CP -> IO FilePath -file config = Config.getFile config "files" "saveGame" - --- | We save a simple serialized version of the current state. -saveGame :: State -> IO () -saveGame state = do - f <- file (sconfig state) - encodeEOF f state - --- | Restore a saved game. Returns either the current game state, --- or a string containing an error message if restoring the game fails. -restoreGame :: Config.CP -> IO (Either State String) -restoreGame config = - E.catch (do - mvBkp config - f <- file config - state <- strictDecodeEOF (f ++ ".bkp") - return (Left state)) - (\ e -> case e :: E.IOException of - _ -> return (Right $ - "Restore failed: " - ++ (unwords . lines) (show e))) - --- | Move the savegame file to a backup slot. -mvBkp :: Config.CP -> IO () -mvBkp config = - do - f <- file config - renameFile f (f ++ ".bkp") - --- | Remove the backup of the savegame. Should be called before any --- non-error exit from the game. Sometimes it does not exist and it's OK. --- We don't bother reporting any other exceptions, either, because the file --- is relatively unimportant and because most probably the exception --- would be reported for the main savefile, where it should not be overlooked. -rmBkp :: Config.CP -> IO () -rmBkp config = - do - f <- file config - E.catch (removeFile (f ++ ".bkp")) - (\ e -> case e :: E.IOException of _ -> return ()) diff --git a/src/State.hs b/src/State.hs deleted file mode 100644 --- a/src/State.hs +++ /dev/null @@ -1,189 +0,0 @@ -module State where - -import qualified Data.Map as M -import qualified Data.Set as S -import qualified Data.IntSet as IS -import Data.Binary -import qualified Config -import qualified System.Random as R - -import Actor -import Geometry -import Loc -import Level -import qualified Dungeon -import Item -import Message -import WorldLoc - --- | The 'State' contains all the game state that has to be saved. --- In practice, we maintain extra state, but that state is state --- accumulated during a turn or relevant only to the current session. -data State = State - { splayer :: ActorId -- ^ represents the player-controlled actor - , scursor :: Cursor -- ^ cursor location and level to return to - , shistory :: [Message] - , ssensory :: SensoryMode - , sdisplay :: DisplayMode - , stime :: Time - , sflavour :: FlavourMap -- ^ association of flavour to items - , sdisco :: Discoveries -- ^ items (kinds) that have been discovered - , sdungeon :: Dungeon.Dungeon -- ^ all but the current dungeon level - , slid :: LevelId - , scounter :: (Int, Int) -- ^ stores next hero index and monster index - , sparty :: IS.IntSet -- ^ heroes in the party - , srandom :: R.StdGen -- ^ current random generator - , sconfig :: Config.CP - } - deriving Show - -data Cursor = Cursor - { ctargeting :: Bool -- ^ are we in targeting mode? - , clocLn :: LevelId -- ^ cursor level - , clocation :: Loc -- ^ cursor coordinates - , creturnLn :: LevelId -- ^ the level current player resides on - } - deriving Show - -slevel :: State -> Level -slevel State{slid, sdungeon} = sdungeon Dungeon.! slid - -defaultState :: Dungeon.Dungeon -> LevelId -> Loc -> R.StdGen -> State -defaultState dng lid ploc g = - State - (AHero 0) -- hack: the hero is not yet alive - (Cursor False lid ploc lid) - [] - Implicit Normal - 0 - M.empty - S.empty - dng - lid - (0, 0) - IS.empty - g - Config.defaultCP - -updateCursor :: (Cursor -> Cursor) -> State -> State -updateCursor f s = s { scursor = f (scursor s) } - -updateHistory :: ([String] -> [String]) -> State -> State -updateHistory f s = s { shistory = f (shistory s) } - -updateTime :: (Time -> Time) -> State -> State -updateTime f s = s { stime = f (stime s) } - -updateDiscoveries :: (Discoveries -> Discoveries) -> State -> State -updateDiscoveries f s = s { sdisco = f (sdisco s) } - -updateLevel :: (Level -> Level) -> State -> State -updateLevel f s = updateDungeon (Dungeon.adjust f (slid s)) s - -updateDungeon :: (Dungeon.Dungeon -> Dungeon.Dungeon) -> State -> State -updateDungeon f s = s {sdungeon = f (sdungeon s)} - -toggleVision :: State -> State -toggleVision s = s { ssensory = case ssensory s of Vision 1 -> Smell - Vision n -> Vision (n-1) - Smell -> Implicit - Implicit -> Vision 3 } - -toggleOmniscient :: State -> State -toggleOmniscient s = s { sdisplay = if sdisplay s == Omniscient - then Normal - else Omniscient } - -toggleTerrain :: State -> State -toggleTerrain s = s { sdisplay = case sdisplay s of Terrain 1 -> Normal - Terrain n -> Terrain (n-1) - _ -> Terrain 4 } - -instance Binary State where - put (State player cursor hst sense disp time flav disco dng lid ct - party g config) = - do - put player - put cursor - put hst - put sense - put disp - put time - put flav - put disco - put dng - put lid - put ct - put party - put (show g) - put config - get = - do - player <- get - cursor <- get - hst <- get - sense <- get - disp <- get - time <- get - flav <- get - disco <- get - dng <- get - lid <- get - ct <- get - party <- get - g <- get - config <- get - return - (State player cursor hst sense disp time flav disco dng lid ct - party (read g) config) - -instance Binary Cursor where - put (Cursor act cln loc rln) = - do - put act - put cln - put loc - put rln - get = - do - act <- get - cln <- get - loc <- get - rln <- get - return (Cursor act cln loc rln) - -data SensoryMode = - Implicit - | Vision Int - | Smell - deriving (Show, Eq) - -instance Binary SensoryMode where - put Implicit = putWord8 0 - put (Vision n) = putWord8 1 >> put n - put Smell = putWord8 2 - get = do - tag <- getWord8 - case tag of - 0 -> return Implicit - 1 -> fmap Vision get - 2 -> return Smell - _ -> fail "no parse (SensoryMode)" - -data DisplayMode = - Normal - | Omniscient - | Terrain Int -- TODO: unused right now - deriving (Show, Eq) - -instance Binary DisplayMode where - put Normal = putWord8 0 - put Omniscient = putWord8 1 - put (Terrain n) = putWord8 2 >> put n - get = do - tag <- getWord8 - case tag of - 0 -> return Normal - 1 -> return Omniscient - 2 -> fmap Terrain get - _ -> fail "no parse (DisplayMode)" diff --git a/src/Strategy.hs b/src/Strategy.hs deleted file mode 100644 --- a/src/Strategy.hs +++ /dev/null @@ -1,50 +0,0 @@ -module Strategy where - -import Control.Monad - -import Frequency - --- Monster strategies - --- | A strategy is a choice of frequency tables. -newtype Strategy a = Strategy { runStrategy :: [Frequency a] } - deriving Show - --- | Strategy is a monad. TODO: Can we write this as a monad transformer? -instance Monad Strategy where - return x = Strategy $ return (Frequency [(1, x)]) - m >>= f = Strategy $ - filter (\ (Frequency xs) -> not (null xs)) - [ Frequency [ (p * q, b) - | (p, a) <- runFrequency x, - y <- runStrategy (f a), - (q, b) <- runFrequency y ] - | x <- runStrategy m ] - -liftFrequency :: Frequency a -> Strategy a -liftFrequency f = - Strategy $ filter (\ (Frequency xs) -> not (null xs)) $ return f - -instance MonadPlus Strategy where - mzero = Strategy [] - mplus (Strategy xs) (Strategy ys) = Strategy (xs ++ ys) - -infixr 2 .| - -(.|) :: Strategy a -> Strategy a -> Strategy a -(.|) = mplus - -reject :: Strategy a -reject = mzero - -infix 3 .=> - -(.=>) :: Bool -> Strategy a -> Strategy a -p .=> m | p = m - | otherwise = mzero - -only :: (a -> Bool) -> Strategy a -> Strategy a -only p s = - do - x <- s - p x .=> return x diff --git a/src/StrategyState.hs b/src/StrategyState.hs deleted file mode 100644 --- a/src/StrategyState.hs +++ /dev/null @@ -1,203 +0,0 @@ -module StrategyState where - -import qualified Data.List as L -import qualified Data.IntMap as IM -import Data.Maybe -import Control.Monad -import Control.Arrow - -import Loc -import Dir -import Level -import Actor -import ActorState -import Content.ActorKind -import Frequency -import Perception -import Strategy -import State -import Action -import Actions -import ItemAction -import Content.ItemKind -import Item -import qualified Effect -import qualified Tile -import qualified Kind - -{- -Monster movement ----------------- - -Not all monsters use the same algorithm to find the hero. -Some implemented and unimplemented methods are listed below: - -* Random -The simplest way to have a monster move is at random. - -* Sight -If a monster can see the hero (as an approximation, -we assume it is the case when the hero can see the monster), -the monster should move toward the hero. - -* Smell -The hero leaves a trail when moving toward the dungeon. -For a certain timespan (100--200 moves), it is possible -for certain monsters to detect that a hero has been at a certain field. -Once a monster is following a trail, it should move to the -neighboring field where the hero has most recently visited. - -* Noise -The hero makes noise. If the distance between the hero -and the monster is small enough, the monster can hear the hero -and moves into the approximate direction of the hero. --} - -strategy :: ActorId -> State -> Perceptions -> Strategy (Action ()) -strategy actor oldState@State{splayer = pl, stime = time} per = - strat - where - lvl@Level{lsmell = nsmap, lxsize} = slevel oldState - Actor { bkind = ak, bloc = me, bdir = ad, - btarget = tgt, bitems = items } = - getActor actor oldState - mk = Kind.getKind ak - delState = deleteActor actor oldState - enemyVisible a l = - -- We assume monster sight is infravision, so light has no significance. - asight mk && actorReachesActor a actor l me per Nothing || - -- Any enemy is visible if adjacent (e. g., a monster player). - memActor a delState && adjacent lxsize me l - -- If no heroes on the level, monsters go at each other. TODO: let them - -- earn XP by killing each other to make this dangerous to the player. - hs = L.map (AHero *** bloc) $ - IM.assocs $ lheroes $ slevel delState - ms = L.map (AMonster *** bloc) $ - IM.assocs $ lmonsters $ slevel delState - -- Below, "foe" is the hero (or a monster, or loc) chased by the actor. - (newTgt, floc) = - case tgt of - TEnemy a ll | focusedMonster -> - if memActor a delState - then let l = bloc $ getActor a delState - in if enemyVisible a l - then (TEnemy a l, Just l) - else if isJust (snd closest) || me == ll - then closest -- prefer visible foes - else (tgt, Just ll) -- last known location of enemy - else closest -- enemy not on the level, temporarily chase others - TLoc loc -> if me == loc - then closest - else (tgt, Just loc) -- ignore everything and go to loc - _ -> closest - closest = - let hsAndTraitor = if isAMonster pl - then (pl, bloc $ getPlayerBody delState) : hs - else hs - foes = if L.null hsAndTraitor then ms else hsAndTraitor - -- We assume monster sight is infravision, so light has no effect. - foeVisible = L.filter (uncurry enemyVisible) foes - foeDist = L.map (\ (a, l) -> (distance lxsize me l, l, a)) foeVisible - in case foeDist of - [] -> (TCursor, Nothing) - _ -> let (_, l, a) = L.minimum foeDist - in (TEnemy a l, Just l) - onlyFoe = onlyMoves (maybe (const False) (==) floc) me - towardsFoe = case floc of - Nothing -> const mzero - Just loc -> - let foeDir = towards lxsize me loc - in only (\ x -> dirDistSq lxsize foeDir x <= 1) - lootHere x = not $ L.null $ lvl `iat` x - onlyLoot = onlyMoves lootHere me - exitHere x = let t = lvl `at` x in Tile.isExit t - onlyExit = onlyMoves exitHere me - onlyKeepsDir k = only (\ x -> maybe True (\ d -> dirDistSq lxsize d x <= k) ad) - onlyKeepsDir_9 = only (\ x -> maybe True (\ d -> neg x /= d) ad) - onlyNoMs = onlyMoves (unoccupied (levelMonsterList delState)) me - -- Monsters don't see doors more secret than that. Enforced when actually - -- opening doors, too, so that monsters don't cheat. TODO: remove the code - -- duplication, though. - openPower = Tile.SecretStrength $ - case strongestItem items "ring" of - Just i -> aiq mk + jpower i - Nothing -> aiq mk - openableHere = openable lvl openPower - onlyOpenable = onlyMoves openableHere me - accessibleHere = accessible lvl me - onlySensible = onlyMoves (\ l -> accessibleHere l || openableHere l) me - focusedMonster = aiq mk > 10 - smells = - L.map fst $ - L.sortBy (\ (_, s1) (_, s2) -> compare s2 s1) $ - L.filter (\ (_, s) -> s > 0) $ - L.map (\ x -> let sm = smelltime $ IM.findWithDefault - (SmellTime 0) (me `shift` x) nsmap - in (x, (sm - time) `max` 0)) (moves lxsize) - fromDir allowAttacks d = dirToAction actor newTgt allowAttacks `liftM` d - - strat = - fromDir True (onlyFoe moveFreely) - .| isJust floc .=> liftFrequency (msum freqs) - .| lootHere me .=> actionPickup - .| fromDir True moveAround - actionPickup = return $ actorPickupItem actor - tis = lvl `iat` me - freqs = [applyFreq items 1, applyFreq tis 2, - throwFreq items 2, throwFreq tis 5, towardsFreq] - applyFreq is multi = Frequency - [ (benefit * multi, actionApply (iname ik) i) - | i <- is, - let ik = Kind.getKind (jkind i), - let benefit = - (1 + jpower i) * Effect.effectToBenefit (ieffect ik), - benefit > 0, - asight mk || iname ik /= "scroll"] - actionApply groupName = applyGroupItem actor (applyToVerb groupName) - throwFreq is multi = if not $ asight mk then mzero else Frequency - [ (benefit * multi, actionThrow (iname ik) i) - | i <- is, - let ik = Kind.getKind (jkind i), - let benefit = - - (1 + jpower i) * Effect.effectToBenefit (ieffect ik), - benefit > 0, - -- Wasting swords would be too cruel to the player. - iname ik /= "sword"] - actionThrow groupName = - zapGroupItem actor (fromJust floc) (zapToVerb groupName) - towardsFreq = - let freqs2 = runStrategy $ fromDir False moveTowards - in if asight mk && not (L.null freqs2) - then scale 30 $ head freqs2 - else mzero - moveTowards = onlySensible $ onlyNoMs (towardsFoe moveFreely) - moveAround = - onlySensible $ - (if asight mk then onlyNoMs else id) $ - asmell mk .=> L.foldr ((.|) . return) reject smells - .| onlyOpenable moveFreely - .| moveFreely - moveFreely = onlyLoot moveRandomly - .| onlyExit (onlyKeepsDir 2 moveRandomly) - .| aiq mk > 15 .=> onlyKeepsDir 0 moveRandomly - .| aiq mk > 10 .=> onlyKeepsDir 1 moveRandomly - .| aiq mk > 5 .=> onlyKeepsDir 2 moveRandomly - .| onlyKeepsDir_9 moveRandomly - .| moveRandomly - onlyMoves :: (Loc -> Bool) -> Loc -> Strategy Dir -> Strategy Dir - onlyMoves p l = only (\ x -> p (l `shift` x)) - moveRandomly :: Strategy Dir - moveRandomly = liftFrequency $ uniform (moves lxsize) - -dirToAction :: ActorId -> Target -> Bool -> Dir -> Action () -dirToAction actor tgt allowAttacks dir = do - -- set new direction - updateAnyActor actor $ \ m -> m { bdir = Just dir, btarget = tgt } - -- perform action - tryWith (advanceTime actor) $ - -- if the following action aborts, we just advance the time and continue - -- TODO: ensure time is taken for other aborted actions in this file - moveOrAttack allowAttacks True actor dir - -wait :: ActorId -> Strategy (Action ()) -wait actor = return $ advanceTime actor diff --git a/src/Tile.hs b/src/Tile.hs deleted file mode 100644 --- a/src/Tile.hs +++ /dev/null @@ -1,93 +0,0 @@ -module Tile where - -import qualified Data.List as L -import qualified Data.Array.Unboxed as A -import Data.Binary - -import Content.TileKind -import qualified Feature as F -import qualified Kind -import Geometry - -newtype SecretStrength = SecretStrength{secretStrength :: Time} - deriving (Show, Eq, Ord) -instance Binary SecretStrength where - put = put . secretStrength - get = fmap SecretStrength get - --- TODO: remove this file - -wallId, openingId, floorLightId, floorDarkId, unknownId, doorOpenId, doorClosedId, doorSecretId, stairsUpId, stairsDownId :: Kind.Id TileKind -wallId = Kind.getId (\ t -> tsymbol t == '#' && (L.null $ tfeature t)) -openingId = Kind.getId (\ t -> tsymbol t == '.' && kindHasFeature F.Exit t) -floorLightId = - Kind.getId (\ t -> tsymbol t == '.' && kindHas [F.Lit] [F.Exit] t) -floorDarkId = - Kind.getId (\ t -> tsymbol t == '.' && kindHas [] [F.Exit, F.Lit] t) -unknownId = Kind.getId ((== ' ') . tsymbol) -doorOpenId = Kind.getId (kindHasFeature F.Closable) -doorClosedId = Kind.getId (kindHasFeature F.Openable) -doorSecretId = Kind.getId (kindHasFeature F.Hidden) -stairsUpId = Kind.getId (kindHas [F.Lit, F.Climbable] []) -stairsDownId = Kind.getId (kindHas [F.Lit, F.Descendable] []) - --- | The player can't tell if the tile is a secret door or not. -canBeSecretDoor :: Kind.Id TileKind -> Bool -canBeSecretDoor t = - let u = Kind.getKind t - s = Kind.getKind doorSecretId - in tsymbol u == tsymbol s && - tname u == tname s && - tcolor u == tcolor s && - tcolor2 u == tcolor2 s - -isUnknown :: Kind.Id TileKind -> Bool -isUnknown t = t == unknownId - -isOpening :: Kind.Id TileKind -> Bool -isOpening t = t == openingId - -kindHasFeature :: F.Feature -> TileKind -> Bool -kindHasFeature f t = f `elem` tfeature t - -kindHas :: [F.Feature] -> [F.Feature] -> TileKind -> Bool -kindHas yes no t = L.all (flip kindHasFeature t) yes && - not (L.any (flip kindHasFeature t) no) - -hasFeature :: F.Feature -> Kind.Id TileKind -> Bool -hasFeature f t = kindHasFeature f (Kind.getKind t) - --- | Does not block vision. Essential for efficiency of FOV, hence tabulated. -clearTab :: A.UArray (Kind.Id TileKind) Bool -clearTab = let f _ k acc = kindHasFeature F.Clear k : acc - clearAssocs = Kind.foldrWithKey f [] - in A.listArray Kind.boundsId clearAssocs - -isClear :: Kind.Id TileKind -> Bool -isClear i = clearTab A.! i - --- | Is lit on its own. Essential for efficiency of Perception, hence tabulated. -litTab :: A.UArray (Kind.Id TileKind) Bool -litTab = let f _ k acc = kindHasFeature F.Lit k : acc - litAssocs = Kind.foldrWithKey f [] - in A.listArray Kind.boundsId litAssocs - -isLit :: Kind.Id TileKind -> Bool -isLit i = litTab A.! i - --- | Does not block land movement. -isWalkable :: Kind.Id TileKind -> Bool -isWalkable = hasFeature F.Walkable - - --- | Provides an exit from a room. -isExit :: Kind.Id TileKind -> Bool -isExit = hasFeature F.Exit - --- | Is a good candidate to deposit items, replace by other tiles, etc. -isBoring :: Kind.Id TileKind -> Bool -isBoring t = - let fs = tfeature (Kind.getKind t) - optional = [F.Exit, F.Lit] - mandatory = [F.Walkable, F.Clear] - in fs L.\\ optional `L.elem` L.permutations mandatory diff --git a/src/Turn.hs b/src/Turn.hs deleted file mode 100644 --- a/src/Turn.hs +++ /dev/null @@ -1,272 +0,0 @@ -module Turn where - -import Control.Monad -import Control.Monad.State hiding (State, state) -import qualified Data.List as L -import qualified Data.Map as M -import qualified Data.Set as S -import qualified Data.Ord as Ord -import qualified Data.IntMap as IM -import qualified Data.Char as Char - -import Action -import Actions -import Command -import qualified Config -import Display hiding (display) -import EffectAction -import Keybindings -import qualified Keys as K -import Level -import Actor -import ActorState -import Random -import State -import Strategy -import StrategyState - --- One turn proceeds through the following functions: --- --- handle --- handleMonsters, handleMonster --- nextMove --- handle (again) --- --- OR: --- --- handle --- handlePlayer, playerCommand --- handleMonsters, handleMonster --- nextMove --- handle (again) --- --- What's happening where: --- --- handle: determine who moves next, --- dispatch to handleMonsters or handlePlayer --- --- handlePlayer: remember, display, get and process commmand(s), --- update smell map, update perception --- --- handleMonsters: find monsters that can move --- --- handleMonster: determine and process monster action, advance monster time --- --- nextMove: advance global game time, HP regeneration, monster generation --- --- This is rather convoluted, and the functions aren't named very aptly, so we --- should clean this up later. TODO. - --- | Decide if the hero is ready for another move. --- Dispatch to either 'handleMonsters' or 'handlePlayer'. -handle :: Action () -handle = - do - debug "handle" - state <- get - let ptime = btime (getPlayerBody state) -- time of player's next move - let time = stime state -- current game time - debug $ "handle: time check. ptime = " ++ show ptime ++ ", time = " ++ show time - if ptime > time - then handleMonsters -- the hero can't make a move yet; monsters first - else handlePlayer -- it's the hero's turn! - - -- TODO: readd this, but only for the turns when anything moved - -- and only after a rendering delay is added, so that the move is visible - -- on modern computers. Use the same delay for running (not disabled now). - -- We redraw the map even between player moves so that the movements of fast - -- monsters can be traced on the map. - -- displayGeneric ColorFull (const "") - --- | Handle monster moves. Perform moves for individual monsters as long as --- there are monsters that have a move time which is less than or equal to --- the current time. --- TODO: We should replace thi structure using a priority search queue/tree. -handleMonsters :: Action () -handleMonsters = - do - debug "handleMonsters" - time <- gets stime - ms <- gets (lmonsters . slevel) - pl <- gets splayer - if IM.null ms - then nextMove - else let order = Ord.comparing (btime . snd) - (i, m) = L.minimumBy order (IM.assocs ms) - actor = AMonster i - in if btime m > time || actor == pl - then nextMove -- no monster is ready for another move - else handleMonster actor - --- | Handle the move of a single monster. -handleMonster :: ActorId -> Action () -handleMonster actor = - do - debug "handleMonster" - state <- get - per <- currentPerception - -- Run the AI: choses an action from those given by the AI strategy. - action <- - rndToAction $ - frequency (head (runStrategy (strategy actor state per .| wait actor))) - action - handleMonsters - --- | After everything has been handled for the current game time, we can --- advance the time. Here is the place to do whatever has to be done for --- every time unit; currently, that's monster generation. --- TODO: nextMove may not be a good name. It's part of the problem of the --- current design that all of the top-level functions directly call each --- other, rather than being called by a driver function. -nextMove :: Action () -nextMove = - do - debug "nextMove" - modify (updateTime (+1)) - regenerateLevelHP - generateMonster - handle - --- | Handle the move of the hero. -handlePlayer :: Action () -handlePlayer = - do - debug "handlePlayer" - remember -- the hero perceives his (potentially new) surroundings - -- determine perception before running player command, in case monsters - -- have opened doors ... - oldPlayerTime <- gets (btime . getPlayerBody) - withPerception playerCommand -- get and process a player command - -- at this point, the command was successful and possibly took some time - newPlayerTime <- gets (btime . getPlayerBody) - if newPlayerTime == oldPlayerTime - then withPerception handlePlayer -- no time taken, repeat - else do - state <- get - pl <- gets splayer - let time = stime state - ploc = bloc (getPlayerBody state) - sTimeout = Config.get (sconfig state) "monsters" "smellTimeout" - -- update smell - when (isAHero pl) $ -- only humans leave strong scent - modify (updateLevel (updateSmell (IM.insert ploc - (SmellTime (time + sTimeout))))) - -- determine player perception and continue with monster moves - withPerception handleMonsters - --- | Determine and process the next player command. -playerCommand :: Action () -playerCommand = - do - lxsize <- gets (lxsize . slevel) - display -- draw the current surroundings - history -- update the message history and reset current message - tryRepeatedlyWith stopRunning $ -- on abort, just ask for a new command - ifRunning continueRun $ do - k <- session nextCommand - handleKey lxsize stdKeybindings k - - -- Design thoughts (in order to get rid or partially rid of the somewhat - -- convoluted design we have): We have three kinds of commands. - -- - -- Normal commands: they take time, so after handling the command, state changes, - -- time passes and monsters get to move. - -- - -- Instant commands: they take no time, and do not change the state. - -- - -- Meta commands: they take no time, but may change the state. - -- - -- Ideally, they can all be handled via the same (event) interface. We maintain an - -- event queue where we store what has to be handled next. The event queue is a sorted - -- list where every event contains the timestamp when the event occurs. The current game - -- time is equal to the head element of the event queue. Currently, we only have action - -- events. An actor gets to move on an event. The actor is responsible for reinsterting - -- itself in the event queue. Possible new events may include HP regeneration events, - -- monster generation events, or actor death events. - -- - -- If an action does not take any time, the actor just reinserts itself with the current - -- time into the event queue. If the insert algorithm makes sure that later events with - -- the same time get precedence, this will work just fine. - -- - -- It's important that we decouple issues like HP regeneration from action events if we - -- do it like that, because otherwise, HP regeneration may occur multiple times. - -- - -- Given this scheme, we may get orphaned events: a HP regeneration event for a dead - -- monster may be scheduled. Or a move event for a monster suddenly put to sleep. We - -- therefore have to given handlers the option of accessing and cleaning up the event - -- queue. - --- The remaining functions in this module are individual actions or helper --- functions. - --- TODO: Should be defined in Command module. -helpCommand :: Described (Action ()) -helpCommand = Described "display help" displayHelp - --- | Display command help. TODO: Should be defined in Actions module. -displayHelp :: Action () -displayHelp = do - let coImage sess k = - let macros = snd sess - domain = M.keysSet macros - in if k `S.member` domain then [] else - k : [ from | (from, to) <- M.assocs macros, to == k ] - aliases <- session (return . coImage) - let helpString = keyHelp aliases stdKeybindings - messageOverlayConfirm "Basic keys:" helpString - abort - -heroSelection :: [(K.Key, Command)] -heroSelection = - let heroSelect k = (K.Char (Char.intToDigit k), - Undescribed $ - selectPlayer (AHero k) >> withPerception playerCommand) - in fmap heroSelect [0..9] - -stdKeybindings :: Keybindings -stdKeybindings = Keybindings - { kdir = moveDirCommand, - kudir = runDirCommand, - kother = M.fromList $ - heroSelection ++ - [ -- interaction with the dungeon - (K.Char 'c', closeCommand), - - (K.Char '<', ascendCommand), - (K.Char '>', descendCommand), - - (K.Char '*', monsterCommand), - (K.Char '/', floorCommand), - (K.Tab , heroCommand), - - -- items - (K.Char 'g', pickupCommand), - (K.Char 'd', dropCommand), - (K.Char 'i', inventoryCommand), - (K.Char 'q', quaffCommand), - (K.Char 'r', readCommand), - (K.Char 't', throwCommand), - (K.Char 'a', aimCommand), - - -- wait - (K.Char '.', Undescribed playerAdvanceTime), - - -- saving or ending the game - (K.Char 'X', saveCommand), - (K.Char 'Q', quitCommand), - - -- debug modes - (K.Char 'R', Undescribed $ modify toggleVision), - (K.Char 'O', Undescribed $ modify toggleOmniscient), - (K.Char 'T', Undescribed $ modify toggleTerrain), - (K.Char 'I', Undescribed $ gets (lmeta . slevel) >>= abortWith), - - -- information for the player - (K.Char 'V', versionCommand), - (K.Char 'P', historyCommand), - (K.Char 'D', dumpCommand), - (K.Char '?', helpCommand), - (K.Return , acceptCommand displayHelp), - (K.Esc , cancelCommand) - ] - } diff --git a/src/Utils/Assert.hs b/src/Utils/Assert.hs deleted file mode 100644 --- a/src/Utils/Assert.hs +++ /dev/null @@ -1,55 +0,0 @@ -module Utils.Assert (assert, blame, failure, allB, checkM, trueM, falseM) where - -import Control.Exception (assert) -import Debug.Trace (trace) - -infix 1 `blame` --- | If the condition fails, Display the value blamed for the failure. --- Used as in "assert (c /= 0 `blame` c) $ 10 / c". -blame :: Show a => Bool -> a -> Bool -{-# INLINE blame #-} -blame condition blamed - | condition = True - | otherwise = - let s = "Contract failed and the following is to blame:\n" ++ - " " ++ show blamed - in trace s False - --- | Like Prelude.undefined, but shows the source location --- and also the value to blame for the failure. To be used as in: --- assert `failure` ((x1, y1), (x2, y2), "designate a vertical line") -failure :: Show a => (Bool -> b -> b) -> a -> b -{-# INLINE failure #-} -failure assrt blamed = - let s = "Internal failure occured and the following is to blame:\n" ++ - " " ++ show blamed - in trace s $ - assrt False (error "Assert.failure: no error location (upgrade to GHC 7.4)") - --- | Like List.all, but if the predicate fails, blame all the list elements --- and especially those for which it fails. To be used as in: --- assert (allB (>= 0) [yf, xf, y1, x1, y2, x2]) -allB :: Show a => (a -> Bool) -> [a] -> Bool -{-# INLINE allB #-} -allB predicate l = - let s = show (filter (not . predicate) l) ++ " in the context of " ++ show l - in blame (all predicate l) s - --- | Check that the value returned from a monad action satisfies a predicate. --- Reports source location and the suspects. Drops the value. -checkM :: (Show a, Monad m) => - (Bool -> m () -> m ()) -> (c -> Bool) -> a -> c -> m () -checkM assrt predicate blamed value - | predicate value = return () - | otherwise = - let s = "The returned value is wrong and the following is to blame:\n" ++ - " " ++ show blamed - in trace s $ - assrt False - (error "Assert.checkM: no error location (upgrade to GHC 7.4)") - --- | Verifies that the returned value is true (respectively, false). Used as in: --- open newValve >>= assert `trueM` (newValve, "is already opened, not new") -trueM, falseM :: (Show a, Monad m) => (Bool -> m () -> m ()) -> a -> Bool -> m () -trueM assrt = checkM assrt id -falseM assrt = checkM assrt not diff --git a/src/Utils/File.hs b/src/Utils/File.hs deleted file mode 100644 --- a/src/Utils/File.hs +++ /dev/null @@ -1,34 +0,0 @@ -module Utils.File (encodeEOF, strictDecodeEOF) where - -import System.IO -import Data.Binary -import qualified Data.ByteString.Lazy as LBS -import qualified Codec.Compression.Zlib as Z - --- Note that LBS.writeFile opens the file in binary mode. -encodeCompressedFile :: Binary a => FilePath -> a -> IO () -encodeCompressedFile f = LBS.writeFile f . Z.compress . encode - --- The "OK" is used as an EOF marker to ensure any problems with --- corrupted files are reported to the user ASAP. -encodeEOF :: Binary a => FilePath -> a -> IO () -encodeEOF f a = encodeCompressedFile f (a, "OK") - -strictReadCompressedFile :: FilePath -> IO LBS.ByteString -strictReadCompressedFile f = - withBinaryFile f ReadMode $ \ h -> do - c <- LBS.hGetContents h - let d = Z.decompress c - LBS.length d `seq` return d - -strictDecodeCompressedFile :: Binary a => FilePath -> IO a -strictDecodeCompressedFile = fmap decode . strictReadCompressedFile - --- The "OK" EOF marker ensures any detectable file corruption --- is discovered and reported before the function returns. -strictDecodeEOF :: Binary a => FilePath -> IO a -strictDecodeEOF f = do - (a, n) <- strictDecodeCompressedFile f - if n == "OK" - then return a - else error $ "Fatal error: corrupted file " ++ f diff --git a/src/Utils/Multiline.hs b/src/Utils/Multiline.hs deleted file mode 100644 --- a/src/Utils/Multiline.hs +++ /dev/null @@ -1,8 +0,0 @@ -module Utils.Multiline (multiline) where - -import qualified Language.Haskell.TH as TH -import qualified Language.Haskell.TH.Quote as TQ - --- | Handle multiline verbatim string expressions. -multiline :: TQ.QuasiQuoter -multiline = TQ.QuasiQuoter (TH.litE . TH.stringL) undefined undefined undefined diff --git a/src/Version.hs b/src/Version.hs deleted file mode 100644 --- a/src/Version.hs +++ /dev/null @@ -1,11 +0,0 @@ -module Version where - -import Data.Version - --- Cabal -import qualified Paths_Allure as Self (version) - -import qualified Display - -version :: String -version = showVersion Self.version ++ " (" ++ Display.displayId ++ " frontend)" diff --git a/src/WorldLoc.hs b/src/WorldLoc.hs deleted file mode 100644 --- a/src/WorldLoc.hs +++ /dev/null @@ -1,24 +0,0 @@ -module WorldLoc - ( LevelId(..), levelName, levelNumber, WorldLoc) where - -import Data.Binary -import Loc - --- | Level ids are integers and (for now) ordered linearly. -newtype LevelId = LambdaCave Int - deriving (Show, Eq, Ord) - -instance Binary LevelId where - put (LambdaCave n) = put n - get = fmap LambdaCave get - --- | Name of a level. -levelName :: LevelId -> String -levelName (LambdaCave n) = "The Lambda Cave " ++ show n - --- | Depth of a level. -levelNumber :: LevelId -> Int -levelNumber (LambdaCave n) = n - --- | A world location is a level together with a location on that level. -type WorldLoc = (LevelId, Loc) diff --git a/src/config.bot b/src/config.bot deleted file mode 100644 --- a/src/config.bot +++ /dev/null @@ -1,62 +0,0 @@ -; This is the default config file, included in the binary itself. -; The game looks for the user config file in ~/.Allure/config. -; We restricts the config file format by insisting that -; options are case-sensitive and permitting only ';' comments. - -; If you contribute to the game, please create directory ~/.Allure/ -; as described in README.md. In this way, you will not accidentally -; commit your private high scores (nor your save files) to the game -; git repository. - -[dungeon] -; fixed caves for the first levels, then randomly picked caves -LambdaCave_1: caveRogue -LambdaCave_2: caveRogue -LambdaCave_3: caveEmpty -; access to stairs may be blocked, so normally only suitable for the last level: -LambdaCave_4: caveNoise -depth: 1000 - -[engine] -fovMode: digital -;fovMode: permissive -;fovMode: shadow -fovRadius: 4 -;startingRandomGenerator: 42 -;dungeonRandomGenerator: 42 -;BotAllure 42 20000000 | Allure > /tmp/log - -; paths to various game files; relative to ~/.Allure/ -; (or analogous prefixes for other OSes, see getAppUserDataDirectory) -[files] -highScores: scores -saveGame: save - -[heroes] -HeroName_0: you -HeroName_1: Haskell Alvin -HeroName_2: Alonzo Barkley -HeroName_3: Ernst Abraham -HeroName_4: Samuel Saunders -HeroName_5: Roger Robin -baseHP: 1000000 -extraHeroes: 4 -firstDeathEnds: False - -[macros] -; TODO: the following does not work yet: -; ; throw a dart at the closest monster -; t: asterisk Return t Return -; TODO: in gtk it could be implemented via unGetChan, -; unless we prefer an explicit command queue, with flushing, etc. -; -; Handy with Vi keys: -comma: g -; Angband compatibility: -v: t - -[monsters] -smellTimeout: 1000 - -[ui] -historyMax: 500 diff --git a/src/config.default b/src/config.default deleted file mode 100644 --- a/src/config.default +++ /dev/null @@ -1,61 +0,0 @@ -; This is the default config file, included in the binary itself. -; The game looks for the user config file in ~/.Allure/config. -; We restricts the config file format by insisting that -; options are case-sensitive and permitting only ';' comments. - -; If you contribute to the game, please create directory ~/.Allure/ -; as described in README.md. In this way, you will not accidentally -; commit your private high scores (nor your save files) to the game -; git repository. - -[dungeon] -; fixed caves for the first levels, then randomly picked caves -LambdaCave_1: caveRogue -LambdaCave_2: caveRogue -LambdaCave_3: caveEmpty -; access to stairs may be blocked, so only suitable for the last level: -LambdaCave_10: caveNoise -depth: 10 - -[engine] -fovMode: digital -;fovMode: permissive -;fovMode: shadow -fovRadius: 40 -;startingRandomGenerator: 42 -;dungeonRandomGenerator: 42 - -; paths to various game files; relative to ~/.Allure/ -; (or analogous prefixes for other OSes, see getAppUserDataDirectory) -[files] -highScores: scores -saveGame: save - -[heroes] -HeroName_0: you -HeroName_1: Haskell Alvin -HeroName_2: Alonzo Barkley -HeroName_3: Ernst Abraham -HeroName_4: Samuel Saunders -HeroName_5: Roger Robin -baseHP: 50 -extraHeroes: 0 -firstDeathEnds: False - -[macros] -; TODO: the following does not work yet: -; ; throw a dart at the closest monster -; t: asterisk Return t Return -; TODO: in gtk it could be implemented via unGetChan, -; unless we prefer an explicit command queue, with flushing, etc. -; -; Handy with Vi keys: -comma: g -; Angband compatibility: -v: t - -[monsters] -smellTimeout: 1000 - -[ui] -historyMax: 500