packages feed

LambdaHack 0.1.20090606 → 0.1.20110117

raw patch · 67 files changed

+4920/−3605 lines, 67 filesdep +ConfigFiledep +MissingHdep +filepathdep ~basedep ~gtkdep ~mtl

Dependencies added: ConfigFile, MissingH, filepath, old-time

Dependency ranges changed: base, gtk, mtl, vty

Files

− Actor.hs 
@@ -1,29 +0,0 @@-module Actor where--import Level-import Monster--data Actor = AMonster Int  -- offset in monster list-           | APlayer-  deriving (Show, Eq)--getActor :: Level -> Player -> Actor -> Monster-getActor lvl p (AMonster n) = lmonsters lvl !! n-getActor lvl p APlayer      = p--updateActor :: (Monster -> Monster) ->                  -- the update-               (Monster -> Level -> Player -> IO a) ->  -- continuation-               Actor ->                                 -- who to update-               Level -> Player -> IO a                  -- transformed continuation-updateActor f k (AMonster n) lvl p = -  let (m,ms) = updateMonster f n (lmonsters lvl)-  in  k m (updateMonsters lvl (const ms)) p-updateActor f k APlayer      lvl p = k p lvl (f p)--updateMonster :: (Monster -> Monster) -> Int -> [Monster] -> (Monster, [Monster])-updateMonster f n ms =-  case splitAt n ms of-    (pre, x : post) -> let m = f x in (m, pre ++ [m] ++ post)-    xs              -> error "updateMonster"--
− COPYING 
@@ -1,340 +0,0 @@-		    GNU GENERAL PUBLIC LICENSE-		       Version 2, June 1991-- Copyright (C) 1989, 1991 Free Software Foundation, Inc.-                       51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA- Everyone is permitted to copy and distribute verbatim copies- of this license document, but changing it is not allowed.--			    Preamble--  The licenses for most software are designed to take away your-freedom to share and change it.  By contrast, the GNU General Public-License is intended to guarantee your freedom to share and change free-software--to make sure the software is free for all its users.  This-General Public License applies to most of the Free Software-Foundation's software and to any other program whose authors commit to-using it.  (Some other Free Software Foundation software is covered by-the GNU Library General Public License instead.)  You can apply it to-your programs, too.--  When we speak of free software, we are referring to freedom, not-price.  Our General Public Licenses are designed to make sure that you-have the freedom to distribute copies of free software (and charge for-this service if you wish), that you receive source code or can get it-if you want it, that you can change the software or use pieces of it-in new free programs; and that you know you can do these things.--  To protect your rights, we need to make restrictions that forbid-anyone to deny you these rights or to ask you to surrender the rights.-These restrictions translate to certain responsibilities for you if you-distribute copies of the software, or if you modify it.--  For example, if you distribute copies of such a program, whether-gratis or for a fee, you must give the recipients all the rights that-you have.  You must make sure that they, too, receive or can get the-source code.  And you must show them these terms so they know their-rights.--  We protect your rights with two steps: (1) copyright the software, and-(2) offer you this license which gives you legal permission to copy,-distribute and/or modify the software.--  Also, for each author's protection and ours, we want to make certain-that everyone understands that there is no warranty for this free-software.  If the software is modified by someone else and passed on, we-want its recipients to know that what they have is not the original, so-that any problems introduced by others will not reflect on the original-authors' reputations.--  Finally, any free program is threatened constantly by software-patents.  We wish to avoid the danger that redistributors of a free-program will individually obtain patent licenses, in effect making the-program proprietary.  To prevent this, we have made it clear that any-patent must be licensed for everyone's free use or not licensed at all.--  The precise terms and conditions for copying, distribution and-modification follow.--		    GNU GENERAL PUBLIC LICENSE-   TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION--  0. This License applies to any program or other work which contains-a notice placed by the copyright holder saying it may be distributed-under the terms of this General Public License.  The "Program", below,-refers to any such program or work, and a "work based on the Program"-means either the Program or any derivative work under copyright law:-that is to say, a work containing the Program or a portion of it,-either verbatim or with modifications and/or translated into another-language.  (Hereinafter, translation is included without limitation in-the term "modification".)  Each licensee is addressed as "you".--Activities other than copying, distribution and modification are not-covered by this License; they are outside its scope.  The act of-running the Program is not restricted, and the output from the Program-is covered only if its contents constitute a work based on the-Program (independent of having been made by running the Program).-Whether that is true depends on what the Program does.--  1. You may copy and distribute verbatim copies of the Program's-source code as you receive it, in any medium, provided that you-conspicuously and appropriately publish on each copy an appropriate-copyright notice and disclaimer of warranty; keep intact all the-notices that refer to this License and to the absence of any warranty;-and give any other recipients of the Program a copy of this License-along with the Program.--You may charge a fee for the physical act of transferring a copy, and-you may at your option offer warranty protection in exchange for a fee.--  2. You may modify your copy or copies of the Program or any portion-of it, thus forming a work based on the Program, and copy and-distribute such modifications or work under the terms of Section 1-above, provided that you also meet all of these conditions:--    a) You must cause the modified files to carry prominent notices-    stating that you changed the files and the date of any change.--    b) You must cause any work that you distribute or publish, that in-    whole or in part contains or is derived from the Program or any-    part thereof, to be licensed as a whole at no charge to all third-    parties under the terms of this License.--    c) If the modified program normally reads commands interactively-    when run, you must cause it, when started running for such-    interactive use in the most ordinary way, to print or display an-    announcement including an appropriate copyright notice and a-    notice that there is no warranty (or else, saying that you provide-    a warranty) and that users may redistribute the program under-    these conditions, and telling the user how to view a copy of this-    License.  (Exception: if the Program itself is interactive but-    does not normally print such an announcement, your work based on-    the Program is not required to print an announcement.)--These requirements apply to the modified work as a whole.  If-identifiable sections of that work are not derived from the Program,-and can be reasonably considered independent and separate works in-themselves, then this License, and its terms, do not apply to those-sections when you distribute them as separate works.  But when you-distribute the same sections as part of a whole which is a work based-on the Program, the distribution of the whole must be on the terms of-this License, whose permissions for other licensees extend to the-entire whole, and thus to each and every part regardless of who wrote it.--Thus, it is not the intent of this section to claim rights or contest-your rights to work written entirely by you; rather, the intent is to-exercise the right to control the distribution of derivative or-collective works based on the Program.--In addition, mere aggregation of another work not based on the Program-with the Program (or with a work based on the Program) on a volume of-a storage or distribution medium does not bring the other work under-the scope of this License.--  3. You may copy and distribute the Program (or a work based on it,-under Section 2) in object code or executable form under the terms of-Sections 1 and 2 above provided that you also do one of the following:--    a) Accompany it with the complete corresponding machine-readable-    source code, which must be distributed under the terms of Sections-    1 and 2 above on a medium customarily used for software interchange; or,--    b) Accompany it with a written offer, valid for at least three-    years, to give any third party, for a charge no more than your-    cost of physically performing source distribution, a complete-    machine-readable copy of the corresponding source code, to be-    distributed under the terms of Sections 1 and 2 above on a medium-    customarily used for software interchange; or,--    c) Accompany it with the information you received as to the offer-    to distribute corresponding source code.  (This alternative is-    allowed only for noncommercial distribution and only if you-    received the program in object code or executable form with such-    an offer, in accord with Subsection b above.)--The source code for a work means the preferred form of the work for-making modifications to it.  For an executable work, complete source-code means all the source code for all modules it contains, plus any-associated interface definition files, plus the scripts used to-control compilation and installation of the executable.  However, as a-special exception, the source code distributed need not include-anything that is normally distributed (in either source or binary-form) with the major components (compiler, kernel, and so on) of the-operating system on which the executable runs, unless that component-itself accompanies the executable.--If distribution of executable or object code is made by offering-access to copy from a designated place, then offering equivalent-access to copy the source code from the same place counts as-distribution of the source code, even though third parties are not-compelled to copy the source along with the object code.--  4. You may not copy, modify, sublicense, or distribute the Program-except as expressly provided under this License.  Any attempt-otherwise to copy, modify, sublicense or distribute the Program is-void, and will automatically terminate your rights under this License.-However, parties who have received copies, or rights, from you under-this License will not have their licenses terminated so long as such-parties remain in full compliance.--  5. You are not required to accept this License, since you have not-signed it.  However, nothing else grants you permission to modify or-distribute the Program or its derivative works.  These actions are-prohibited by law if you do not accept this License.  Therefore, by-modifying or distributing the Program (or any work based on the-Program), you indicate your acceptance of this License to do so, and-all its terms and conditions for copying, distributing or modifying-the Program or works based on it.--  6. Each time you redistribute the Program (or any work based on the-Program), the recipient automatically receives a license from the-original licensor to copy, distribute or modify the Program subject to-these terms and conditions.  You may not impose any further-restrictions on the recipients' exercise of the rights granted herein.-You are not responsible for enforcing compliance by third parties to-this License.--  7. If, as a consequence of a court judgment or allegation of patent-infringement or for any other reason (not limited to patent issues),-conditions are imposed on you (whether by court order, agreement or-otherwise) that contradict the conditions of this License, they do not-excuse you from the conditions of this License.  If you cannot-distribute so as to satisfy simultaneously your obligations under this-License and any other pertinent obligations, then as a consequence you-may not distribute the Program at all.  For example, if a patent-license would not permit royalty-free redistribution of the Program by-all those who receive copies directly or indirectly through you, then-the only way you could satisfy both it and this License would be to-refrain entirely from distribution of the Program.--If any portion of this section is held invalid or unenforceable under-any particular circumstance, the balance of the section is intended to-apply and the section as a whole is intended to apply in other-circumstances.--It is not the purpose of this section to induce you to infringe any-patents or other property right claims or to contest validity of any-such claims; this section has the sole purpose of protecting the-integrity of the free software distribution system, which is-implemented by public license practices.  Many people have made-generous contributions to the wide range of software distributed-through that system in reliance on consistent application of that-system; it is up to the author/donor to decide if he or she is willing-to distribute software through any other system and a licensee cannot-impose that choice.--This section is intended to make thoroughly clear what is believed to-be a consequence of the rest of this License.--  8. If the distribution and/or use of the Program is restricted in-certain countries either by patents or by copyrighted interfaces, the-original copyright holder who places the Program under this License-may add an explicit geographical distribution limitation excluding-those countries, so that distribution is permitted only in or among-countries not thus excluded.  In such case, this License incorporates-the limitation as if written in the body of this License.--  9. The Free Software Foundation may publish revised and/or new versions-of the General Public License from time to time.  Such new versions will-be similar in spirit to the present version, but may differ in detail to-address new problems or concerns.--Each version is given a distinguishing version number.  If the Program-specifies a version number of this License which applies to it and "any-later version", you have the option of following the terms and conditions-either of that version or of any later version published by the Free-Software Foundation.  If the Program does not specify a version number of-this License, you may choose any version ever published by the Free Software-Foundation.--  10. If you wish to incorporate parts of the Program into other free-programs whose distribution conditions are different, write to the author-to ask for permission.  For software which is copyrighted by the Free-Software Foundation, write to the Free Software Foundation; we sometimes-make exceptions for this.  Our decision will be guided by the two goals-of preserving the free status of all derivatives of our free software and-of promoting the sharing and reuse of software generally.--			    NO WARRANTY--  11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY-FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW.  EXCEPT WHEN-OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES-PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED-OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF-MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.  THE ENTIRE RISK AS-TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU.  SHOULD THE-PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,-REPAIR OR CORRECTION.--  12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING-WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR-REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,-INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING-OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED-TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY-YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER-PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE-POSSIBILITY OF SUCH DAMAGES.--		     END OF TERMS AND CONDITIONS--	    How to Apply These Terms to Your New Programs--  If you develop a new program, and you want it to be of the greatest-possible use to the public, the best way to achieve this is to make it-free software which everyone can redistribute and change under these terms.--  To do so, attach the following notices to the program.  It is safest-to attach them to the start of each source file to most effectively-convey the exclusion of warranty; and each file should have at least-the "copyright" line and a pointer to where the full notice is found.--    <one line to give the program's name and a brief idea of what it does.>-    Copyright (C) <year>  <name of author>--    This program is free software; you can redistribute it and/or modify-    it under the terms of the GNU General Public License as published by-    the Free Software Foundation; either version 2 of the License, or-    (at your option) any later version.--    This program is distributed in the hope that it will be useful,-    but WITHOUT ANY WARRANTY; without even the implied warranty of-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the-    GNU General Public License for more details.--    You should have received a copy of the GNU General Public License-    along with this program; if not, write to the Free Software-    Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA---Also add information on how to contact you by electronic and paper mail.--If the program is interactive, make it output a short notice like this-when it starts in an interactive mode:--    Gnomovision version 69, Copyright (C) year name of author-    Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.-    This is free software, and you are welcome to redistribute it-    under certain conditions; type `show c' for details.--The hypothetical commands `show w' and `show c' should show the appropriate-parts of the General Public License.  Of course, the commands you use may-be called something other than `show w' and `show c'; they could even be-mouse-clicks or menu items--whatever suits your program.--You should also get your employer (if you work as a programmer) or your-school, if any, to sign a "copyright disclaimer" for the program, if-necessary.  Here is a sample; alter the names:--  Yoyodyne, Inc., hereby disclaims all copyright interest in the program-  `Gnomovision' (which makes passes at compilers) written by James Hacker.--  <signature of Ty Coon>, 1 April 1989-  Ty Coon, President of Vice--This General Public License does not permit incorporating your program into-proprietary programs.  If your program is a subroutine library, you may-consider it more useful to permit linking proprietary applications with the-library.  If this is what you want to do, use the GNU Library General-Public License instead of this License.
+ CREDITS view
@@ -0,0 +1,4 @@+Developers who have contributed significantly to LambdaHack:++Andres Loeh+Mikolaj Konarski
+ DESIGN.markdown view
@@ -0,0 +1,200 @@+Design notes+============++Here is a rationale for some design decisions and implementation details.+Not all of the sketched features are implemented and not everything+is implemented as described.+++Level generation+----------------++Each level 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.++  * Stairs up and down are placed. Stairs are always located in two different+    randomly chosen rooms.+++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, 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.++Once we compute the reachable fields using FOV, it is possible+to compute what the hero can actually see. Fields adjacent to the hero+(also diagonally) can always be seen (except for walls).+Fields that have light and are reachable can also be seen.+We treat floor of rooms as having light, whereas corridors and rock are dark.++Walls reflect light. They can be seen only if an adjacent floor field+can also be seen. In particular, walls cannot be seen when passing+a corridor on the outside of a room, but can be seen from the inside of a room.+++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.+++Dungeon tiles+-------------++Abstract musings for now; not implemented.++The hero and the monsters (later, in short, 'monsters') can transform a tile,+which can be represented by a graph, with edges labeled by prerequisites+and cost of transformation. Monsters can also melee across a tile border,+and it's always permitted (e.g. fighting a ghost embedded in a wall)+and the kind of the tiles involved is irrelevant.++For tile design, I disregard sound and the monster's sense of hearing,+because sound is best conveyed to the player through sound effects,+not by painting tiles, and this requires lots of work.+Acoustics is quite complex, too. Right now, sound ignores tiles+and sound cues are given as text messages, e.g., when a monster attacks+or is hit or when distant (but not too distant?) monsters fight or when+a level is eerie silent, when the hero enters.++Monsters can interact directly and non-destructively with dungeon tiles+in the following ways: they can move trough, see through, shoot through+and smell (or inhale) across.++Three different kinds of things can pass through a tile:++  * objects: big, slow, pushy things (monsters passing through tiles+    and throwing objects from inventory across tiles)++  * projectiles and gases: monsters shooting small, fast and sharp things+    (arrows and bolts from the quiver) and monsters inhaling tiny, slow+    particles (smells, smoke, fog, poisonous gases)++  * light: monsters seeing clearly across a tile (light that just leaks+    through a cloth or produces a distorted image though a waterfall+    does not count)++For simplicity I assume that if big objects can move through,+small objects can as well (no Kevlar curtains nor automatic doors).+Also, I merged projectiles and gases, assuming that if small objects+can get through, so can tiny objects (no self-sealing rubber walls)+and the reverse (no vents in walls).++I can find no such simplifications for light. I only assume that the light+that carries the picture is in itself too weak to illuminate any tile+(so you can stand in a pitch dark corridor and observe a nearby sunny room).+Consequently, room lighting and monster field of view calculations+are very loosely coupled.++Below are tables with examples of different tile kinds.++The case of tiles that can be shot through and smelled through:++                   can see through    cannot see through++    can pass       floor, open door   curtain, waterfall++    cannot pass    fence, grate       grate with waterfall++The case of tiles that cannot be shot through and that block smell:++                   can see through    cannot see through++    can pass       none               none++    cannot pass    crystal, glass     rock, closed door++Note that acid pools and pits do not count as "cannot pass" tiles.+First, axes and rocks can be thrown across (or into) them.+Second, the hero and monsters can be pushed into them (and perish).+The player cannot steer the hero into the acid pool not by physical+impossibility, but by the self preservation instinct of the hero.+So, an acid pool is in the same category as empty floor and it's up to the+monster AI routines to check if the monster has wings (and a brain of any size)+before entering. Such tiles should probably be marked as "damage this large+unless flying". Similarly with water and swimming, lava pool and fire+resistance, poison cloud and poison resistance, etc. No action is forbidden+there, but each action has consequences.
− Display.hs 
@@ -1,12 +0,0 @@-module Display (module D) where---- wrapper for selected Display frontend--#ifdef CURSES-import Display.Curses as D-#elif GTK-import Display.Gtk as D-#else-import Display.Vty as D-#endif-
− Display/Curses.hs 
@@ -1,115 +0,0 @@-module Display.Curses-  (displayId, startup, shutdown,-   display, nextEvent, setBG, setFG, setBold, Session,-   white, black, yellow, blue, magenta, red, green, attr, Display.Curses.Attr) where--import UI.HSCurses.Curses as C hiding (setBold)-import qualified UI.HSCurses.CursesHelper as C-import Data.List as L-import Data.Map as M-import Data.Char-import qualified Data.ByteString as BS--import Geometry--displayId = "curses"--data Session =-  Session-    { win :: Window,-      styles :: Map (Maybe AttrColor, Maybe AttrColor) C.CursesStyle }--startup :: (Session -> IO ()) -> IO ()-startup k =-  do-    C.start-    C.startColor-    cursSet CursorInvisible-    nr <- colorPairs-    let s = [ ((f,b), C.Style (toFColor f) (toBColor b))-            | f <- Nothing : L.map Just [minBound..maxBound],-              b <- Nothing : L.map Just [minBound..maxBound] ]-    let (ks, vs) = unzip (tail s)  -- drop the Nothing/Nothing combo-    ws <- C.convertStyles (take (nr - 1) vs)-    k (Session C.stdScr (M.fromList (zip ks ws)))--shutdown :: Session -> IO ()-shutdown w = C.end--display :: Area -> Session -> (Loc -> (Display.Curses.Attr, Char)) -> String -> String -> IO ()-display ((y0,x0),(y1,x1)) (Session { win = w, styles = s }) f msg status =-  do-    erase-    mvWAddStr w 0 0 msg-    sequence_ [ let (a,c) = f (y,x) in C.setStyle (findWithDefault C.defaultCursesStyle a s) >> mvWAddStr w (y+1) x [c]-              | x <- [x0..x1], y <- [y0..y1] ]-    mvWAddStr w (y1+2) 0 status-    refresh-{--    in  V.update vty (Pic NoCursor -         ((renderBS attr (BS.pack (L.map (fromIntegral . ord) (toWidth (x1-x0+1) msg)))) <->-          img <-> -          (renderBS attr (BS.pack (L.map (fromIntegral . ord) (toWidth (x1-x0+1) status))))))--}--{--toWidth :: Int -> String -> String-toWidth n x = take n (x ++ repeat ' ')--}--nextEvent :: Session -> IO String-nextEvent session =-  do-    e <- C.getKey refresh-    case e of-      C.KeyChar '<' -> return "less"-      C.KeyChar '>' -> return "greater"-      C.KeyChar '.' -> return "period"-      C.KeyChar ':' -> return "colon"-      C.KeyChar ',' -> return "comma"-      C.KeyChar ' ' -> return "space"-      C.KeyChar '?' -> return "question"-      C.KeyChar '*' -> return "asterisk"-      C.KeyChar '\ESC' -> return "Escape"-      C.KeyChar c   -> return [c]-      C.KeyExit     -> return "Escape"-      _             -> nextEvent session--type Attr = (Maybe AttrColor, Maybe AttrColor)--attr = (Nothing, Nothing)--data AttrColor = White | Black | Yellow | Blue | Magenta | Red | Green -  deriving (Show, Eq, Ord, Enum, Bounded)--toFColor :: Maybe AttrColor -> C.ForegroundColor-toFColor (Just White)    = C.WhiteF-toFColor (Just Black)    = C.BlackF-toFColor (Just Yellow)   = C.BrownF-toFColor (Just Blue)     = C.DarkBlueF-toFColor (Just Magenta)  = C.PurpleF-toFColor (Just Red)      = C.DarkRedF-toFColor (Just Green)    = C.DarkGreenF-toFColor Nothing         = C.DefaultF--toBColor :: Maybe AttrColor -> C.BackgroundColor-toBColor (Just White)    = C.WhiteB-toBColor (Just Black)    = C.BlackB-toBColor (Just Yellow)   = C.BrownB-toBColor (Just Blue)     = C.DarkBlueB-toBColor (Just Magenta)  = C.PurpleB-toBColor (Just Red)      = C.DarkRedB-toBColor (Just Green)    = C.DarkGreenB-toBColor Nothing         = C.DefaultB--white   = White-black   = Black-yellow  = Yellow-blue    = Blue-magenta = Magenta-red     = Red-green   = Green--setBold (f, b) = (f, b)-setFG c (_, b) = (Just c, b)-setBG c (f, _) = (f, Just c)
− Display/Gtk.hs 
@@ -1,159 +0,0 @@-module Display.Gtk-  (displayId, startup, shutdown, -   display, nextEvent, setBG, setFG, setBold, Session,-   white, black, yellow, blue, magenta, red, green, attr, Attr) where--import Control.Monad-import Control.Concurrent-import Graphics.UI.Gtk hiding (Attr)-import Data.List as L-import Data.IORef-import Data.Map as M--import Geometry--displayId = "gtk"--data Session =-  Session {-    schan :: Chan String,-    stags :: Map AttrKey TextTag,-    sview :: TextView }--doAttr :: TextTag -> AttrKey -> IO ()-doAttr tt (BG Blue)    = set tt [ textTagBackground := "#0000CC" ]-doAttr tt (BG Magenta) = set tt [ textTagBackground := "#CC00CC" ]-doAttr tt (BG Green)   = set tt [ textTagBackground := "#00CC00" ]-doAttr tt (BG Red)     = set tt [ textTagBackground := "#CC0000" ]-doAttr tt (BG White)   = set tt [ textTagBackground := "#FFFFFF" ]-doAttr tt (FG Green)   = set tt [ textTagForeground := "#00FF00" ]-doAttr tt (FG Red)     = set tt [ textTagForeground := "#FF0000" ]-doAttr tt (FG Blue)    = set tt [ textTagForeground := "#0000FF" ]-doAttr tt (FG Yellow)  = set tt [ textTagForeground := "#CCCC00" ]-doAttr tt (FG Black)   = set tt [ textTagForeground := "#000000" ]-doAttr tt _            = return ()--startup :: (Session -> IO ()) -> IO ()-startup k =-  do-    initGUI-    w <- windowNew--    ttt <- textTagTableNew-    -- text attributes-    tts <- fmap M.fromList $-           mapM (\ c -> do-                          tt <- textTagNew Nothing-                          textTagTableAdd ttt tt-                          doAttr tt c-                          return (c,tt))-                [ x | c <- [minBound .. maxBound], x <- [FG c, BG c]]--    -- 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"-    widgetModifyFont tv (Just f)-    currentfont <- newIORef f-    onButtonPress tv (\ e -> case e of-                               Button { eventButton = RightButton } ->-                                 do-                                   fsd <- fontSelectionDialogNew "Choose font"-                                   cf <- readIORef currentfont-                                   -- fd <- fontDescriptionToString cf-                                   -- fontSelectionDialogSetFontName fsd fd-                                   fontSelectionDialogSetPreviewText fsd "+##@##-...|"-                                   response <- dialogRun fsd-                                   when (response == 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-    let white = Color maxBound maxBound maxBound-    widgetModifyBase tv StateNormal black-    widgetModifyText tv StateNormal white--    ec <- newChan -    forkIO $ k (Session ec tts tv)-    -    onKeyPress tv (\ e -> writeChan ec (eventKeyName e) >> yield >> return True)--    idleAdd (yield >> return True) priorityDefaultIdle-    onDestroy w mainQuit -- set quit handler-    widgetShowAll w-    yield-    mainGUI--shutdown _ = mainQuit--display :: Area -> Session -> (Loc -> (Attr, Char)) -> String -> String -> IO ()-display ((y0,x0),(y1,x1)) session f msg status =-  do-    sbuf <- textViewGetBuffer (sview session)-    ttt <- textBufferGetTagTable sbuf-    tb <- textBufferNew (Just ttt)-    let text = unlines [ [ snd (f (y,x)) | x <- [x0..x1] ] | y <- [y0..y1] ]-    textBufferSetText tb (msg ++ "\n" ++ text ++ status)-    sequence_ [ setTo tb (stags session) (y,x) a | -                y <- [y0..y1], x <- [x0..x1], let loc = (y,x), let (a,c) = f (y,x) ]-    textViewSetBuffer (sview session) tb--setTo :: TextBuffer -> Map AttrKey TextTag -> Loc -> Attr -> IO ()-setTo tb tts (ly,lx) a =-  do-    ib <- textBufferGetIterAtLineOffset tb (ly+1) lx-    ie <- textIterCopy ib-    textIterForwardChar ie-    mapM_ (\ c -> textBufferApplyTag tb (tts ! c) ib ie) a--nextEvent :: Session -> IO String-nextEvent = readChan . schan--setBold   = id  -- not supported yet-setBG c   = (BG c :)-setFG c   = (FG c :)-blue      = Blue-magenta   = Magenta-red       = Red-yellow    = Yellow-green     = Green-white     = White-black     = Black-attr      = []--type Attr = [AttrKey]--data AttrKey =-    FG AttrColor-  | BG AttrColor-  deriving (Eq, Ord)--type Color = AttrColor--data AttrColor =-    Blue-  | Magenta-  | Red-  | Green-  | Yellow-  | White-  | Black-  deriving (Eq, Ord, Enum, Bounded)
− Display/Vty.hs 
@@ -1,50 +0,0 @@-module Display.Vty-  (displayId, startup, shutdown,-   display, nextEvent, setBold, setBG, setFG, Session,-   white, black, yellow, blue, magenta, red, green, attr, Attr) where--import Graphics.Vty as V-import Data.List as L-import Data.Char-import qualified Data.ByteString as BS--import Geometry--displayId = "vty"--type Session = V.Vty--startup :: (Session -> IO ()) -> IO ()-startup k = V.mkVty >>= k--display :: Area -> Session -> (Loc -> (Attr, Char)) -> String -> String -> IO ()-display ((y0,x0),(y1,x1)) vty f msg status =-    let img = (foldr (<->) V.empty . -               L.map (foldr (<|>) V.empty . -                      L.map (\ (x,y) -> let (a,c) = f (y,x) in renderChar a c)))-              [ [ (x,y) | x <- [x0..x1] ] | y <- [y0..y1] ]-    in  V.update vty (Pic NoCursor -         (renderBS attr (BS.pack (L.map (fromIntegral . ord) (toWidth (x1 - x0 + 1) msg))) <->-          img <-> -          renderBS attr (BS.pack (L.map (fromIntegral . ord) (toWidth (x1 - x0 + 1) status)))))--toWidth :: Int -> String -> String-toWidth n x = take n (x ++ repeat ' ')--nextEvent :: Session -> IO String-nextEvent session =-  do-    e <- V.getEvent session-    case e of-      V.EvKey (KASCII '<') [] -> return "less"-      V.EvKey (KASCII '>') [] -> return "greater"-      V.EvKey (KASCII '.') [] -> return "period"-      V.EvKey (KASCII ':') [] -> return "colon"-      V.EvKey (KASCII ',') [] -> return "comma"-      V.EvKey (KASCII ' ') [] -> return "space"-      V.EvKey (KASCII '?') [] -> return "question"-      V.EvKey (KASCII '*') [] -> return "asterisk"-      V.EvKey (KASCII c) []   -> return [c]-      V.EvKey KEsc []         -> return "Escape"-      V.EvKey KEnter []       -> return "Return"-      _                       -> nextEvent session
− Display2.hs 
@@ -1,149 +0,0 @@-module Display2 (module Display, module Display2) where--import Data.Set as S-import Data.List as L-import Data.Map as M--import Message-import Display-import State-import Geometry-import Level-import Perception-import Monster-import Item---- | Displays a message on a blank screen. Waits for confirmation.-displayBlankConfirm :: Session -> String -> IO Bool-displayBlankConfirm session txt =-  let x = txt ++ more-  in  do-        display ((0,0),(0,length x - 1)) session (const (attr, ' ')) x ""-        getConfirm session---- | Waits for a space or return.-getConfirm :: Session -> IO Bool-getConfirm session =-  getOptionalConfirm session return (const $ getConfirm session)--getOptionalConfirm :: Session -> (Bool -> IO a) -> (String -> IO a) -> IO a-getOptionalConfirm session h k =-  do-    e <- nextEvent session-    handleModifier e (getOptionalConfirm session h k) $-      case e of-        "space"  -> h True-        "Return" -> h True-        "Escape" -> h False-        _        -> k e---- | Handler that ignores modifier events as they are---   currently produced by the Gtk frontend.-handleModifier :: String -> IO a -> IO a -> IO a-handleModifier e h k =-  case e of-    "Shift_R"   -> h-    "Shift_L"   -> h-    "Control_L" -> h-    "Control_R" -> h-    "Super_L"   -> h-    "Super_R"   -> h-    "Menu"      -> h-    "Alt_L"     -> h-    "Alt_R"     -> h-    _           -> k---- | Configurable event handler for the direction keys. Is used to---   handle player moves, but can also be used for directed commands---   such as open/close.-handleDirection :: String -> ((Y,X) -> IO ()) -> IO () -> IO ()-handleDirection e h k =-  case e of-    "k" -> h (-1,0)-    "j" -> h (1,0)-    "h" -> h (0,-1)-    "l" -> h (0,1)-    "y" -> h (-1,-1)-    "u" -> h (-1,1)-    "b" -> h (1,-1)-    "n" -> h (1,1)-    _   -> k--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, Loc -> 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, \ (y,x) -> M.lookup y m >>= \ n -> M.lookup x n)--displayLevel :: Session -> Level -> Perception -> State -> Message -> IO ()-displayLevel session lvl per state msg = displayOverlay session lvl per state msg "" >> return ()--displayOverlay :: Session -> Level -> Perception -> State -> Message -> String -> IO Bool-displayOverlay session (lvl@(Level nm sz@(sy,sx) ms smap nlmap lmeta))-                     per-                     (state@(State { splayer = player@(Monster { mhp = php, mdir = pdir, mloc = ploc }), stime = time, sassocs = assocs }))-                     msg overlay =-    let-      reachable = preachable per-      visible   = pvisible per-      sSml    = ssensory state == Smell-      sVis    = ssensory state == Vision-      sOmn    = sdisplay state == Omniscient-      sTer    = case sdisplay state of Terrain n -> n; _ -> 0-      lAt     = if sOmn || sTer > 0 then at else rememberAt-      lVision = if sVis-                  then \ vis rea ->-                       if      vis then setBG blue-                       else if rea then setBG magenta-                                   else id-                  else \ vis rea -> id-      (n,over) = stringByLocation (sy+1) overlay -- n is the number of overlay screens-      gold    = maybe 0 (icount . fst) $ findItem (\ i -> iletter i == Just '$') (mitems player)-      disp n msg = -        display ((0,0),sz) session -                 (\ loc -> let tile = nlmap `lAt` loc-                               sml  = ((smap ! loc) - time) `div` 100-                               vis  = S.member loc visible-                               rea  = S.member loc reachable-                               (rv,ra) = case L.find (\ m -> loc == mloc m) (player:ms) of-                                           _ | sTer > 0          -> viewTerrain sTer False (tterrain tile)-                                           Just m | sOmn || vis  -> viewMonster (mtype m) -                                           _ | sSml && sml >= 0  -> viewSmell sml-                                             | otherwise         -> viewTile vis tile assocs-                               vision = lVision vis rea-                           in-                             case over (loc `shift` ((sy+1) * n, 0)) of-                               Just c  ->  (attr, c)-                               _       ->  (ra . vision $ attr, rv))-                msg-                (take 40 (levelName nm ++ repeat ' ') ++-                 take 10 ("$: " ++ show gold ++ repeat ' ') ++-                 take 10 ("HP: " ++ show php ++ repeat ' ') ++-                 take 10 ("T: " ++ show (time `div` 10) ++ repeat ' '))-      msgs = splitMsg sx msg-      perf k []     = perfo k ""-      perf k [xs]   = perfo k xs-      perf k (x:xs) = disp n (x ++ more) >> getConfirm session >>= \ b ->-                      if b then perf k xs else return False-      perfo k xs-        | k < n - 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--
− Dungeon.hs 
@@ -1,254 +0,0 @@-module Dungeon where--import Prelude hiding (floor)-import Control.Monad--import Data.Map as M-import Data.List as L-import Data.Ratio--import State-import Geometry-import Level-import Monster-import Item-import Random--type Corridor = [(Y,X)]-type Room = Area--mkRoom :: Int ->      {- border columns -}-          (Y,X) ->    {- 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 (ym,xm)((y0,x0),(y1,x1)) =-  do-    (ry0,rx0) <- locInArea ((y0 + bd,x0 + bd),(y1 - bd - ym + 1,x1 - bd - xm + 1))-    (ry1,rx1) <- locInArea ((ry0 + ym - 1,rx0 + xm - 1),(y1 - bd,x1 - bd))-    return ((ry0,rx0),(ry1,rx1))--mkNoRoom :: Int ->      {- border columns -}-            Area ->     {- this is an area, not the room itself -}-            Rnd Room    {- this is the upper-left and lower-right corner of the room -}-mkNoRoom bd ((y0,x0),(y1,x1)) =-  do-    (ry,rx) <- locInArea ((y0 + bd,x0 + bd),(y1 - bd,x1 - bd))-    return ((ry,rx),(ry,rx))--mkCorridor :: HV -> (Loc,Loc) -> Area -> Rnd [(Y,X)] {- straight sections of the corridor -}-mkCorridor hv ((y0,x0),(y1,x1)) b =-  do-    (ry,rx) <- findLocInArea b (const True)-      -- (ry,rx) is intermediate point the path crosses-    -- hv decides whether we start in horizontal or vertical direction-    case hv of-      Horiz -> return [(y0,x0),(y0,rx),(y1,rx),(y1,x1)]-      Vert  -> return [(y0,x0),(ry,x0),(ry,x1),(y1,x1)]---- the condition passed to mkCorridor is tricky; there might not always--- exist a suitable intermediate point is the rooms are allowed to be close--- together ...-connectRooms :: Area -> Area -> Rnd [Loc]-connectRooms sa@((sy0,sx0),(sy1,sx1)) ta@((ty0,tx0),(ty1,tx1)) =-  do-    (sy,sx) <- locInArea sa-    (ty,tx) <- locInArea ta-    let xok = sx1 < tx0 - 3-    let xarea = normalizeArea ((sy,sx1+2),(ty,tx0-2))-    let yok = sy1 < ty0 - 3-    let yarea = normalizeArea ((sy1+2,sx),(ty0-2,tx))-    let xyarea = normalizeArea ((sy1+2,sx1+2),(ty0-2,tx0-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 ((sy,sx),(ty,tx)) area--digCorridor :: Corridor -> LMap -> LMap-digCorridor (p1:p2:ps) l =-  digCorridor (p2:ps) -    (M.unionWith corridorUpdate (M.fromList [ (ps,newTile Corridor) | ps <- fromTo p1 p2 ]) l)-  where-    corridorUpdate _ (Tile (Wall hv) is,u)    = (Tile (Opening hv) is,u)-    corridorUpdate _ (Tile (Opening hv) is,u) = (Tile (Opening hv) is,u)-    corridorUpdate _ (Tile (Floor l) is,u)    = (Tile (Floor l) is,u)-    corridorUpdate (x,u) _                    = (x,u)-digCorridor _ l = l-  -newTile :: Terrain -> (Tile, Tile)-newTile t = (Tile t [], Tile Unknown [])--bigroom :: LevelConfig -> -           LevelName -> Rnd (Maybe (Maybe DungeonLoc) -> Maybe (Maybe DungeonLoc) -> Level, Loc, Loc)-bigroom (LevelConfig { levelSize = (sy,sx) }) nm =-  do-    let lmap = digRoom Light ((1,1),(sy-1,sx-1)) (emptyLMap (sy,sx))-    let smap = M.fromList [ ((y,x),-100) | y <- [0..sy], x <- [0..sx] ]-    let lvl = Level nm (sy,sx) [] smap lmap ""-    -- locations of the stairs-    su <- findLoc lvl (const floor)-    sd <- findLoc lvl (\ l t -> floor t && distance (su,l) > 676)-    return (\ lu ld ->-      let flmap = maybe id (\ l -> M.insert su (newTile (Stairs Light Up   l))) lu $-                  maybe id (\ l -> M.insert sd (newTile (Stairs Light Down l))) ld-                  lmap-      in  Level nm (sy,sx) [] smap flmap "bigroom", su, sd)--data LevelConfig =-  LevelConfig {-    levelGrid         :: Rnd (Y,X),-    minRoomSize       :: Rnd (Y,X),-    darkRoomChance    :: Rnd Bool,-    border            :: Int,       -- must be at least 2!-    levelSize         :: (Y,X),     -- lower right point-    extraConnects     :: (Y,X) -> Int, -                                    -- relative to grid-                                    -- (in fact a range, because of duplicate connects)-    noRooms           :: (Y,X) -> Rnd Int,-                                    -- range, relative to grid-    minStairsDistance :: Int,       -- must not be too large-    doorChance        :: Rnd Bool,-    doorOpenChance    :: Rnd Bool,-    doorSecretChance  :: Rnd Bool,-    doorSecretMax     :: Int,-    nrItems           :: Rnd Int,   -- range-    depth             :: Int        -- general indicator of difficulty-  }-    -defaultLevelConfig :: Int -> LevelConfig-defaultLevelConfig d =-  LevelConfig {-    levelGrid         = do-                          y <- randomR (2,4)-                          x <- randomR (3,5)-                          return (y,x),-    minRoomSize       = return (2,2),-    darkRoomChance    = chance $ 1%((22 - (2 * fromIntegral d)) `max` 2),-    border            = 2,-    levelSize         = (22,79),-    extraConnects     = \ (y,x) -> (y*x) `div` 3,   -    noRooms           = \ (y,x) -> randomR (0,(y*x) `div` 3),-    minStairsDistance = 676,-    doorChance        = chance $ 1%2,-    doorOpenChance    = chance $ 1%2,-    doorSecretChance  = chance $ 1%3,-    doorSecretMax     = 15,-    nrItems           = randomR (3,7),-    depth             = d-  }--largeLevelConfig :: Int -> LevelConfig-largeLevelConfig d =-  (defaultLevelConfig d) {-    levelGrid         = return (7,10),-    levelSize         = (77,231),-    extraConnects     = const 10-  }--level :: LevelConfig ->-         LevelName -> Rnd (Maybe (Maybe DungeonLoc) -> Maybe (Maybe DungeonLoc) -> Level, Loc, Loc)-level cfg nm =-  do-    lgrid    <- levelGrid cfg-    lminroom <- minRoomSize cfg-    let gs = M.toList (grid lgrid ((0,0),levelSize cfg))-    -- grid locations of "no-rooms"-    nrnr <- noRooms cfg lgrid-    nr   <- replicateM nrnr (do-                               let (y,x) = lgrid-                               yg <- randomR (0,y-1)-                               xg <- randomR (0,x-1)-                               return (yg,xg))-    rs0 <- mapM (\ (i,r) -> do-                              r' <- if i `elem` nr-                                      then mkNoRoom (border cfg) r-                                      else mkRoom (border cfg) lminroom r-                              return (i,r')) gs-    let rooms :: [(Loc, Loc)]-        rooms = L.map snd rs0-    dlrooms <- (mapM (\ r -> darkRoomChance cfg >>= \ c -> return (r, toDL (not c))) rooms) :: Rnd [((Loc, Loc), DL)]-    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 ! p0-                               r1 = rs ! p1-                           connectRooms r0 r1) allConnects-    let smap = M.fromList [ ((y,x),-100) | let (sy,sx) = levelSize cfg,-                                           y <- [0..sy], x <- [0..sx] ]-    let lmap :: LMap-        lmap = foldr digCorridor (foldr (\ (r, dl) m -> digRoom dl r m) -                                        (emptyLMap (levelSize cfg)) dlrooms) cs-    let lvl = Level nm (levelSize cfg) [] smap lmap "" -    -- convert openings into doors-    dlmap <- fmap M.fromList . mapM-                (\ o@((y,x),(t,r)) -> -                  case t of-                    Tile (Opening hv) _ ->-                      do-                        -- chance for doors-                        rb <- doorChance cfg-                        -- chance for a door to be open-                        ro <- doorOpenChance cfg-                        rs <- if ro then return Nothing-                                    else do -- chance for a door to be secret-                                            rsc <- doorSecretChance cfg-                                            fmap Just-                                                 (if rsc then randomR (1, doorSecretMax cfg)-                                                         else return 0)-                        if rb-                          then return ((y,x),newTile (Door hv rs))-                          else return o-                    _ -> return o) .-                M.toList $ lmap-    -- determine number of items, items and locations for the items-    nri <- nrItems cfg-    is  <- replicateM nri $-           do-             l <- findLoc lvl (const floor)-             t <- newItem (depth cfg) itemFrequency -             return (l,t)-    -- locations of the stairs-    su <- findLoc lvl (const floor)-    sd <- findLoc lvl (\ l t -> floor t && distance (su,l) > minStairsDistance cfg)-    let meta = show allConnects-    return (\ lu ld ->-      let flmap = maybe id (\ l -> M.update (\ (t,r) -> Just $ newTile (Stairs (toDL $ light t) Up   l)) su) lu $-                  maybe id (\ l -> M.update (\ (t,r) -> Just $ newTile (Stairs (toDL $ light t) Down l)) sd) ld $-                  foldr (\ (l,it) f -> M.update (\ (t,r) -> Just (t { titems = it : titems t }, r)) l . f) id is-                  dlmap-      in  Level nm (levelSize cfg) [] smap flmap meta, su, sd)--emptyLMap :: (Y,X) -> LMap-emptyLMap (my,mx) = M.fromList [ ((y,x),newTile Rock) | x <- [0..mx], y <- [0..my] ]---- | If the room has size 1, it is assumed to be a no-room, and a single--- corridor field will be digged instead of a room.-digRoom :: DL -> Room -> LMap -> LMap-digRoom dl ((y0,x0),(y1,x1)) l-  | y0 == y1 && x0 == x1 =-  M.insert (y0,x0) (newTile Corridor) l-  | otherwise =-  let rm = M.fromList $ [ ((y,x),newTile (Floor dl))   | x <- [x0..x1],     y <- [y0..y1]    ]-                     ++ [ ((y,x),newTile (Wall p)) | (x,y,p) <- [(x0-1,y0-1,UL),(x1+1,y0-1,UR),(x0-1,y1+1,DL),(x1+1,y1+1,DR)] ]-                     ++ [ ((y,x),newTile (Wall p)) | x <- [x0..x1], (y,p) <- [(y0-1,U),(y1+1,D)] ]-                     ++ [ ((y,x),newTile (Wall p)) | (x,p) <- [(x0-1,L),(x1+1,R)],  y <- [y0..y1]    ]-  in M.unionWith const rm l--addMonster :: Level -> Player -> Rnd Level-addMonster lvl@(Level { lmonsters = ms, lmap = lmap })-           player@(Monster { mloc = ploc }) =-  do-    rc <- monsterGenChance (lname lvl) ms-    if rc-     then do-            -- TODO: new monsters should always be generated in a place that isn't-            -- visible by the player (if possible -- not possible for bigrooms)-            sm <- findLoc lvl (\ l t -> floor t && -                                        not (l `L.elem` L.map mloc (player : ms)) &&-                                        distance (ploc, l) > 400)-            m <- newMonster sm monsterFrequency-            return (updateMonsters lvl (const (m : ms)))-     else return lvl-
− FOV.hs 
@@ -1,67 +0,0 @@-module FOV where--import Data.Map as M-import Data.Set as S-import Data.List as L-import Data.Ratio-import Debug.Trace--import Geometry-import Level--type Interval = (Rational, Rational)-type Distance = Int-type Progress = Int---- 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 :: ((Distance,Progress) -> Loc) -> LMap -> Distance -> Interval -> Set Loc-scan tr l d (s,e) = -    let ps = downBias (s * fromIntegral d)   -- minimal progress to check-        pe = upBias (e * fromIntegral d)     -- maximal progress to check-        st = if open (l `at` tr (d,ps)) then Just s   -- start in light-                                        else Nothing  -- start in shadow-    in -        -- trace (show (d,s,e,ps,pe)) $-        S.union (S.fromList [tr (d,p) | p <- [ps..pe]]) (scan' st ps pe)-  where-    scan' :: Maybe Rational -> Progress -> Progress -> Set Loc-    -- scan' st ps pe-    --   | trace (show (st,ps,pe)) False = undefined-    scan' (Just s) ps pe-      | s  >= e  = S.empty               -- empty interval-      | ps > pe  = scan tr l (d+1) (s,e) -- reached end, scan next-      | closed (l `at` tr (d,ps)) =-                   let ne = (fromIntegral ps - (1%2)) / (fromIntegral d + (1%2))-                   in  scan tr l (d+1) (s,ne) `S.union` scan' Nothing (ps+1) pe-                                      -- entering shadow-      | otherwise = scan' (Just s) (ps+1) pe-                                      -- continue in light-    scan' Nothing ps pe-      | ps > pe  = S.empty            -- reached end while in shadow-      | open (l `at` tr (d,ps)) = -                   let ns = (fromIntegral ps - (1%2)) / (fromIntegral d - (1%2))-                   in  scan' (Just ns) (ps+1) pe-                                      -- moving out of shadow-      | otherwise = scan' Nothing (ps+1) pe-                                      -- continue in shadow--tr0 (oy,ox) (d,p) = (oy + d,ox + p)-tr1 (oy,ox) (d,p) = (oy + d,ox - p)-tr2 (oy,ox) (d,p) = (oy - d,ox + p)-tr3 (oy,ox) (d,p) = (oy - d,ox - p)-tr4 (oy,ox) (d,p) = (oy + p,ox + d)-tr5 (oy,ox) (d,p) = (oy + p,ox - d)-tr6 (oy,ox) (d,p) = (oy - p,ox + d)-tr7 (oy,ox) (d,p) = (oy - p,ox - d)--fullscan loc lvl = -  S.unions $-  L.map (\ tr -> scan (tr loc) lvl 0 (0,1)) [tr0,tr1,tr2,tr3,tr4,tr5,tr6,tr7]---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))-
− File.hs 
@@ -1,22 +0,0 @@-module File where--import System.IO-import Data.Binary-import qualified Data.ByteString.Lazy as LBS-import Codec.Compression.Zlib as Z--strictReadCompressedFile :: FilePath -> IO LBS.ByteString-strictReadCompressedFile f =-    do-      h <- openBinaryFile f ReadMode-      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--encodeCompressedFile :: Binary a => FilePath -> a -> IO ()-encodeCompressedFile f = LBS.writeFile f . Z.compress . encode-  -- note that LBS.writeFile opens the file in binary mode-
− Frequency.hs 
@@ -1,31 +0,0 @@-module Frequency where--import Control.Monad--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))
− Geometry.hs 
@@ -1,60 +0,0 @@-module Geometry where---- | Game time in turns. (Placement in module Geometry is not ideal.)-type Time = Int--type X = Int-type Y = Int--type Loc = (Y,X)-type Dir = (Y,X)-type Area = ((Y,X),(Y,X))--towards :: (Loc,Loc) -> Dir-towards ((y0,x0),(y1,x1)) =-  let dy = y1 - y0-      dx = x1 - x0-      angle = atan (fromIntegral dy / fromIntegral dx) / (pi / 2)-      dir | angle <= -0.75 = (-1,0)-          | angle <= -0.25 = (-1,1)-          | angle <= 0.25  = (0,1)-          | angle <= 0.75  = (1,1)-          | angle <= 1.25  = (1,0)-          | otherwise      = (0,0)-  in  if dx >= 0 then dir else neg dir--distance :: (Loc,Loc) -> Int-distance ((y0,x0),(y1,x1)) = (y1 - y0)^2 + (x1 - x0)^2--adjacent :: Loc -> Loc -> Bool-adjacent s t = distance (s,t) <= 2--surroundings :: Loc -> [Loc]-surroundings l = map (l `shift`) moves--diagonal :: Loc -> Bool-diagonal (y,x) = y*x /= 0--shift :: Loc -> Dir -> Loc-shift (y0,x0) (y1,x1) = (y0+y1,x0+x1)--neg :: Dir -> Dir-neg (y,x) = (-y,-x)--moves :: [Dir]-moves = [ (x,y) | x <- [-1..1], y <- [-1..1], x /= 0 || y /= 0 ]--up, down, left, right :: Dir-upleft, upright, downleft, downright :: Dir-upleft    = up `shift` left-upright   = up `shift` right-downleft  = down `shift` left-downright = down `shift` right-up        = (-1,0)-down      = (1,0)-left      = (0,-1)-right     = (0,1)--horiz, vert :: [Dir]-horiz = [left, right]-vert  = [up, down]
− Item.hs 
@@ -1,234 +0,0 @@-module Item where--import Data.Binary-import Data.Map as M-import Data.Set as S-import Data.List as L-import Data.Maybe-import Data.Char-import Control.Monad--import Display-import Geometry-import Random--data Item = Item-             { icount  :: Int,-               itype   :: ItemType,   -               iletter :: Maybe Char }  -- inventory identifier-  deriving Show--data ItemType =-   Ring- | Scroll- | Potion PotionType- | Wand- | Amulet- | Gem- | Gold- deriving (Eq, Ord, Show)--data PotionType =-   PotionWater- | PotionHealing- deriving (Eq, Ord, Show)--data Appearance =-   Clear- | White- deriving (Eq, Show)--type Assocs = M.Map ItemType Appearance-type Discoveries = S.Set ItemType--potionType :: PotionType -> String -> String-potionType PotionWater   s = s ++ " of water"-potionType PotionHealing s = s ++ " of healing"--appearance :: Appearance -> String -> String-appearance Clear s = "clear " ++ s-appearance White s = "white " ++ s--instance Binary Item where-  put (Item icount itype iletter) = put icount >> put itype >> put iletter-  get = liftM3 Item get get get--instance Binary ItemType where-  put Ring       = putWord8 0-  put Scroll     = putWord8 1-  put (Potion t) = putWord8 2 >> put t-  put Wand       = putWord8 3-  put Amulet     = putWord8 4-  put Gem        = putWord8 5-  put Gold       = putWord8 6-  get = do-          tag <- getWord8-          case tag of-            0 -> return Ring-            1 -> return Scroll-            2 -> liftM Potion get-            3 -> return Wand-            4 -> return Amulet-            5 -> return Gem-            6 -> return Gold--instance Binary PotionType where-  put PotionWater   = putWord8 0-  put PotionHealing = putWord8 1-  get = do-          tag <- getWord8-          case tag of-            0 -> return PotionWater-            1 -> return PotionHealing--instance Binary Appearance where-  put Clear = putWord8 0-  put White = putWord8 1-  get = do-          tag <- getWord8-          case tag of-            0 -> return Clear-            1 -> return White--itemFrequency :: Frequency ItemType-itemFrequency =-  Frequency-  [-    (100, Gold),-    (30,  Gem),-    (20,  Ring),-    (40,  Scroll),-    (20,  Wand),-    (10,  Amulet),-    (30,  Potion PotionWater),-    (10,  Potion PotionHealing)-  ]--itemQuantity :: Int -> ItemType -> Rnd Int-itemQuantity n Gold = (2 * n) *~ d 8-itemQuantity _ _    = return 1--itemLetter :: ItemType -> Maybe Char-itemLetter Gold = Just '$'-itemLetter _    = Nothing---- | Generate an item.-newItem :: Int -> Frequency ItemType -> Rnd Item-newItem n ftp =-  do-    tp <- frequency ftp-    nr <- itemQuantity n tp-    return (Item nr tp (itemLetter tp))---- | Assigns a letter to an item, for inclusion--- in the inventory of the player. 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 (concatMap (maybeToList . iletter) 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 = maxBy cmpLetter--mergeLetter :: Maybe Char -> Maybe Char -> Maybe Char-mergeLetter = mplus--letterRange :: [Char] -> String-letterRange xs = sectionBy (sortBy cmpLetter xs) 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 : " - "--viewItem :: ItemType -> Assocs -> (Char, Attr -> Attr)-viewItem i a = viewItem' i (M.lookup i a)-  where-    viewItem' Ring        _            = ('=', id)-    viewItem' Scroll      _            = ('?', id)-    viewItem' (Potion {}) (Just Clear) = ('!', setBold . setFG blue)-    viewItem' (Potion {}) (Just White) = ('!', setBold . setFG white)-    viewItem' (Potion {}) _            = ('!', id)-    viewItem' Wand        _            = ('/', id)-    viewItem' Gold        _            = ('$', setBold . setFG yellow)-    viewItem' Gem         _            = ('*', setFG red)-    viewItem' Amulet      _            = ('"', id)-    viewItem' _           _            = ('~', id)---- | Adds an item to a list of items, joining equal items.--- Also returns the joined item.-joinItem :: Item -> [Item] -> (Item,[Item])-joinItem i is = case findItem (\ j -> itype i == itype j) is of-                  Nothing     -> (i, i : is)-                  Just (j,js) -> let n = i { icount = icount i + icount j,-                                             iletter = mergeLetter (iletter j) (iletter i) }-                                 in (n, n : js)---- | Finds an item in a list of items.-findItem :: (Item -> Bool) -> [Item] -> Maybe (Item, [Item])-findItem p is = findItem' [] is-  where-    findItem' acc []     = Nothing-    findItem' acc (i:is)-      | p i              = Just (i, reverse acc ++ is)-      | otherwise        = findItem' (i:acc) is--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 (obj ++ "s")--objectItem :: Assocs -> Discoveries -> Int -> ItemType -> String-objectItem _ _ n Ring       = makeObject n id "ring"-objectItem _ _ n Scroll     = makeObject n id "scroll"-objectItem a d n (Potion t) = makeObject n (identified a d (Potion t)) "potion"-objectItem _ _ n Wand       = makeObject n id "wand"-objectItem _ _ n Amulet     = makeObject n id "amulet"-objectItem _ _ n Gem        = makeObject n id "gem"-objectItem _ _ n Gold       = makeObject n id "gold piece"--identified :: Assocs -> Discoveries -> ItemType -> String -> String-identified a d i-  | i `S.member` d = case i of-                       Potion t -> potionType t-                       _        -> ("really strange " ++)-  | otherwise      = case M.lookup i a of-                       Just ap  -> appearance ap-                       _        -> ("really strange " ++)
+ LICENSE view
@@ -0,0 +1,28 @@+Copyright (c) 2008--2011 Andres Loeh+Copyright (c) 2010--2011 Mikolaj Konarski++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.+3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF+SUCH DAMAGE.
LambdaHack.cabal view
@@ -1,9 +1,10 @@ cabal-version: >= 1.2 name:          LambdaHack-version:       0.1.20090606-license:       GPL-license-file:  COPYING-data-files:    README+version:       0.1.20110117+license:       BSD3+license-file:  LICENSE+data-files:    LICENSE, CREDITS, DESIGN.markdown, PLAYING.markdown,+               README.markdown, LambdaHack.config.example author:        Andres Loeh <mail@andres-loeh.de> maintainer:    Andres Loeh <mail@andres-loeh.de> description:   a small roguelike game@@ -15,31 +16,37 @@   description:   enable curses support   default:       False -flag gtk-  description:   enable gtk support-  default:       True+flag vty+  description:   enable vty support+  default:       False  executable LambdaHack   main-is:       LambdaHack.hs-  other-modules: Actor, Display, Display2, Dungeon, File,-                 FOV, Frequency, Geometry, Item, LambdaHack,-                 Level, Message, Monster, Perception, Random,-                 Save, Setup, State, Strategy, Style, Turn,-                 Version-  build-depends: base >= 3 && < 4, containers >= 0.1 && < 1, binary >= 0.4 && < 1,-                 random >= 1 && < 2, zlib >= 0.4 && < 1, bytestring >= 0.9 && < 1,-                 directory >= 1 && < 2, mtl >= 1.1 && < 2-  extensions:    CPP+  hs-source-dirs:src+  other-modules: Actor, Action, Actions, Command, Display, Display2, Dungeon,+                 File, FOV, Frequency, Geometry, Item, ItemState,+                 Keys, Keybindings, LambdaHack, Level, LevelState, Message,+                 Monster, Perception, Random, Save, State, Strategy,+                 StrategyState, Turn, Version, HighScores, Config,+                 Grammar+  build-depends: base >= 4 && <5, containers >= 0.1 && < 1,+                 binary >= 0.4 && < 1,+                 random >= 1 && < 2, zlib >= 0.4 && < 1,+                 bytestring >= 0.9 && < 1, directory >= 1 && < 2,+                 mtl >= 1.1 && < 3, old-time, ConfigFile >= 1.0.6 && < 2,+                 MissingH >= 1.1.0.3 && < 1.2, filepath >= 1.1.0.3 && < 1.2+  extensions:    CPP, FlexibleContexts   if flag(curses) {     other-modules: Display.Curses     build-depends: hscurses >= 1.3 && < 2     cpp-options:   -DCURSES     extra-libraries: curses-  } else { if flag(gtk) {+  } else { if flag(vty) {+    other-modules: Display.Vty+    build-depends: vty >= 4.4+  } else {     other-modules: Display.Gtk-    build-depends: gtk >= 0.9.12 && < 0.11+    build-depends: gtk >= 0.11 && < 0.13     cpp-options:   -DGTK-  } else {-    other-modules: Display.Vty-    build-depends: vty >= 3+    ghc-options:   -threaded   } }
+ LambdaHack.config.example view
@@ -0,0 +1,25 @@+# LambdaHack looks for this file in ~/.LambdaHack/LambdaHack.config++# If you contribute to LambdaHack, please create directory ~/.LambdaHack/+# and move this example config file to ~/.LambdaHack/LambdaHack.config.+# Optionally, also copy LambdaHack.scores to ~/.LambdaConfig/.+# In this way, you won't accidentally commit your private high scores+# (nor your save files) to LambdaHack git repository.++# paths to various game files; relative to ~/.LambdaHack/+# (or analogous prefixes for other OSes, see getAppUserDataDirectory)+[files]+savegame:   LambdaHack.save+highscores: LambdaHack.scores++[engine]+fov_mode: shadow+#fov_mode: diagonal+#fov_mode: permissive+fov_radius: 40++[dungeon]+depth: 10+level3: bigroom+level10: noiseroom+#level1: noiseroom
− LambdaHack.hs 
@@ -1,61 +0,0 @@-module Main where--import System.Directory-import Control.Monad-import Data.Map as M--import State-import Geometry-import Level-import Dungeon-import Perception-import Display2-import Random-import Save-import Turn-import Item--main :: IO ()-main = startup start---- | Either restore a saved game, or setup a new game.-start :: Session -> IO ()-start session =-    do-      -- check if we have a savegame-      x <- doesFileExist savefile-      restored <- if x then do-                              displayBlankConfirm session "Restoring save game"-                              restoreGame-                       else return $ Right "Welcome to LambdaHack!"  -- new game-      case restored of-        Right msg        -> generate session msg-        Left (lvl,state) -> handle session lvl state (perception_ state lvl)-                                   "Welcome back to LambdaHack."---- | Generate the dungeon for a new game, and start the game loop.-generate :: Session -> String -> IO ()-generate session msg =-  do-    -- generate dungeon with 10 levels-    levels <- rndToIO $-              mapM (\n -> (if n == 3 then bigroom else level) (defaultLevelConfig n) $-              LambdaCave n) [1..10]-    let connect :: Maybe (Maybe DungeonLoc) ->-                   [(Maybe (Maybe DungeonLoc) -> Maybe (Maybe DungeonLoc) -> Level, Loc, Loc)] ->-                   [Level]-        connect au [(x,_,_)] = [x au Nothing]-        connect au ((x,_,d):ys@((_,u,_):_)) =-                            let (z:zs) = connect (Just (Just (lname x',d))) ys-                                x'     = x au (Just (Just (lname z,u)))-                            in  x' : z : zs-    let lvls = connect (Just Nothing) levels-    let (lvl,dng) = (head lvls, dungeon (tail lvls))-    -- generate item associations-    let assocs = M.fromList-                   [ (Potion PotionWater,   Clear),-                     (Potion PotionHealing, White) ]-    let state = (defaultState ((\ (_,x,_) -> x) (head levels)) dng)-                  { sassocs = assocs }-    handle session lvl state (perception_ state lvl) msg-
− Level.hs 
@@ -1,512 +0,0 @@-module Level where--import qualified System.Random as R-import Control.Monad--import Data.Binary-import Data.Map as M-import Data.Set as S-import Data.List as L-import Data.Ratio-import Data.Maybe--import Geometry-import Monster-import Item-import Random-import Display---- | Names of the dungeon levels are represented using a--- custom data structure.-data LevelName = LambdaCave Int | Exit-  deriving (Show, Eq, Ord)---- | 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 :: LevelName -> [Monster] -> Rnd Bool-monsterGenChance (LambdaCave n) [] = chance $ 1%50-monsterGenChance (LambdaCave n) _  = chance $ 1%((1000 - (fromIntegral n * 50)) `max` 300)-monsterGenChance _              _  = return False--instance Binary LevelName where-  put (LambdaCave n) = put n-  get = liftM LambdaCave get---- | Provide a textual description of a level name.-levelName :: LevelName -> String-levelName (LambdaCave n) = "The Lambda Cave " ++ show n---- | The complete dungeon is a map from level names to levels.--- We usually store all but the current level in this data structure.-data Dungeon = Dungeon (M.Map LevelName Level)-  deriving Show---- | Create a dungeon from a list of levels.-dungeon :: [Level] -> Dungeon-dungeon = Dungeon . M.fromList . L.map (\ l -> (lname l, l))---- | Extract a level from a dungeon.-getDungeonLevel :: LevelName -> Dungeon -> (Level, Dungeon)-getDungeonLevel ln (Dungeon dng) = (fromJust (M.lookup ln dng), Dungeon (M.delete ln dng))---- | Put a level into a dungeon.-putDungeonLevel :: Level -> Dungeon -> Dungeon-putDungeonLevel lvl (Dungeon dng) = Dungeon (M.insert (lname lvl) lvl dng)--instance Binary Dungeon where-  put (Dungeon dng) = put (M.elems dng)-  get = liftM dungeon get---- | A dungeon location is a level together with a location on--- that level.-type DungeonLoc = (LevelName, Loc)--data Level = Level-              { lname     :: LevelName,-                lsize     :: (Y,X),-                lmonsters :: [Monster],-                lsmell    :: SMap,-                lmap      :: LMap,-                lmeta     :: String }-  deriving Show--updateLMap :: Level -> (LMap -> LMap) -> Level-updateLMap lvl f = lvl { lmap = f (lmap lvl) }--updateMonsters :: Level -> ([Monster] -> [Monster]) -> Level-updateMonsters lvl f = lvl { lmonsters = f (lmonsters lvl) }--instance Binary Level where-  put (Level nm sz@(sy,sx) ms lsmell lmap lmeta) = -        do-          put nm-          put sz-          put ms-          put [ lsmell ! (y,x) | y <- [0..sy], x <- [0..sx] ]-          put [ lmap ! (y,x) | y <- [0..sy], x <- [0..sx] ]-          put lmeta-  get = do-          nm <- get-          sz@(sy,sx) <- get-          ms <- get-          xs <- get-          let lsmell = M.fromList (zip [ (y,x) | y <- [0..sy], x <- [0..sx] ] xs)-          xs <- get-          let lmap   = M.fromList (zip [ (y,x) | y <- [0..sy], x <- [0..sx] ] xs)-          lmeta <- get-          return (Level nm sz ms lsmell lmap lmeta)--type LMap = Map (Y,X) (Tile,Tile)-type SMap = Map (Y,X) Time--data Tile = Tile-              { tterrain :: Terrain,-                titems   :: [Item] }-  deriving Show--instance Binary Tile where-  put (Tile t is) = put t >> put is-  get = liftM2 Tile get get--at         l p = fst (findWithDefault (unknown, unknown) p l)-rememberAt l p = snd (findWithDefault (unknown, unknown) p l)--unknown :: Tile-unknown = Tile Unknown []--data Terrain = Rock-             | Opening Pos-             | Floor DL-             | Unknown-             | Corridor-             | Wall Pos-             | Stairs DL VDir (Maybe DungeonLoc)-             | Door Pos (Maybe Int) -- Nothing: open, Just 0: closed, otherwise secret-  deriving Show--instance Binary Terrain where-  put Rock            = putWord8 0-  put (Opening p)     = putWord8 1 >> put p-  put (Floor dl)      = putWord8 2 >> put dl-  put Unknown         = putWord8 3-  put Corridor        = putWord8 4-  put (Wall p)        = putWord8 5 >> put p-  put (Stairs dl d n) = putWord8 6 >> put dl >> put d >> put n-  put (Door p o)      = putWord8 7 >> put p >> put o-  get = do-          tag <- getWord8-          case tag of-            0 -> return Rock-            1 -> liftM Opening get-            2 -> liftM Floor get-            3 -> return Unknown-            4 -> return Corridor-            5 -> liftM Wall get-            6 -> liftM3 Stairs get get get-            7 -> liftM2 Door get get-            _ -> fail "no parse (Tile)"--data DL = Dark | Light-  deriving (Eq, Show, Bounded)---- | All the wall types that are possible:------     * 'UL': upper left------     * 'U': upper------     * 'UR': upper right------     * 'L': left------     * 'R': right------     * 'DL': lower left------     * 'D': lower------     * 'DR': lower right------ I am tempted to add even more (T-pieces and crossings),--- but currently, we don't need them.-data Pos = UL | U | UR | L | R | DL | D | DR-  deriving (Eq, Show, Bounded)--instance Binary Pos where-  put UL = putWord8 0-  put U  = putWord8 1-  put UR = putWord8 2-  put L  = putWord8 3-  put R  = putWord8 4-  put DL = putWord8 5-  put D  = putWord8 6-  put DR = putWord8 7--  get = do-          tag <- getWord8-          case tag of-            0 -> return UL-            1 -> return U-            2 -> return UR-            3 -> return L-            4 -> return R-            5 -> return DL-            6 -> return D-            7 -> return DR--data HV = Horiz | Vert-  deriving (Eq, Show, Bounded)--fromHV Horiz = True-fromHV Vert  = False--toHV True  = Horiz-toHV False = Vert--instance R.Random HV where-  randomR (a,b) g = case R.randomR (fromHV a,fromHV b) g of-                      (b,g') -> (toHV b,g')-  random g = R.randomR (minBound, maxBound) g--instance Binary HV where-  put Horiz = put True-  put Vert  = put False-  get = get >>= \ b -> if b then return Horiz else return Vert--instance Binary DL where-  put Dark  = put False-  put Light = put True-  get = get >>= \ b -> if b then return Light else return Dark--data VDir = Up | Down-  deriving (Eq, Show)--instance Binary VDir where-  put Up   = put True-  put Down = put False-  get = get >>= \ b -> if b then return Up else return Down--instance Eq Terrain where-  Rock == Rock = True-  Opening d == Opening d' = d == d'-  Floor l == Floor l' = l == l'-  Unknown == Unknown = True-  Corridor == Corridor = True-  Wall p == Wall p' = p == p'-  Stairs dl d t == Stairs dl' d' t' = dl == dl' && d == d' && t == t'-  Door p o == Door p' o' = p == p' && o == o'-  _ == _ = False---- | blocks moves and vision-closed :: Tile -> Bool-closed = not . open--floor :: Tile -> Bool-floor (Tile { tterrain = Floor _ }) = True-floor _                             = False--secret :: Maybe Int -> Bool-secret (Just n) | n /= 0 = True-secret _ = False--toOpen :: Bool -> Maybe Int-toOpen True = Nothing-toOpen False = Just 0--fromDL :: DL -> Bool-fromDL Dark = False-fromDL Light = True--toDL :: Bool -> DL-toDL False = Dark-toDL True  = Light---- | allows moves and vision-open :: Tile -> Bool-open (Tile (Floor {}) _)     = True-open (Tile (Opening {}) _)   = True-open (Tile (Door _ o) _)     = isNothing o-open (Tile Corridor _)       = True-open (Tile (Stairs {}) _)    = True-open _                       = False---- | is lighted on its own-light :: Tile -> Bool-light (Tile (Floor l) _)        = fromDL l-light (Tile (Stairs l _ _) _)   = fromDL l-light _                         = False---- | Passive tiles reflect light from some other (usually adjacent)--- positions. This function returns the offsets from which light is--- reflected. Not all passively lighted tiles reflect from all directions.--- Walls, for instance, cannot usually be seen from the outside.-passive :: Tile -> [Dir]  -passive (Tile (Wall p) _)          = posToDir p-passive (Tile (Opening _) _)       = moves-passive (Tile (Door p Nothing) _)  = moves-passive (Tile (Door p (Just 0)) _) = moves-                                     -- doors can be seen from all sides-passive (Tile (Door p (Just n)) _) = posToDir p-                                     -- secret doors are like walls-passive (Tile (Stairs _ _ _) _)    = moves-passive _                          = []---- | Perceptible is similar to passive, but describes which tiles can--- be seen from which adjacent fields in the dark.-perceptible :: Tile -> [Dir]-perceptible (Tile Rock _) = []-perceptible p = case passive p of-                 [] -> moves-                 ds -> ds---- | Maps wall types to lists of expected floor positions.-posToDir :: Pos -> [Dir]-posToDir UL = [downright]-posToDir U  = [down]-posToDir UR = [downleft]-posToDir L  = [right]-posToDir R  = [left]-posToDir DL = [upright]-posToDir D  = [up]-posToDir DR = [upleft]---- checks for the presence of monsters (and items); it does *not* check--- if the tile is open ...-unoccupied :: [Monster] -> LMap -> Loc -> Bool-unoccupied monsters lvl loc =-  all (\ m -> mloc m /= loc) monsters---- check whether one location is accessible from the other--- precondition: the two locations are next to each other--- currently only implements that doors aren't accessible diagonally,--- and that the target location has to be open-accessible :: LMap -> Loc -> Loc -> Bool-accessible lvl source target =-  let dir = shift source (neg target)-      src = lvl `at` source-      tgt = lvl `at` target-  in  open tgt &&-      (not (diagonal dir) || -       case (tterrain src, tterrain tgt) of-         (Door {}, _)  -> False-         (_, Door {})  -> False-         _             -> True)--findLocInArea :: Area -> (Loc -> Bool) -> Rnd Loc-findLocInArea a@((y0,x0),(y1,x1)) p =-  do-    rx <- randomR (x0,x1)-    ry <- randomR (y0,y1)-    let loc = (ry,rx)-    if p loc then return loc else findLocInArea a p--locInArea :: Area -> Rnd Loc-locInArea a = findLocInArea a (const True)--findLoc :: Level -> (Loc -> Tile -> Bool) -> Rnd Loc-findLoc l@(Level { lsize = sz, lmap = lm }) p =-  do-    loc <- locInArea ((0,0),sz)-    if p loc (lm `at` loc) then return loc-                           else findLoc l p--grid :: (Y,X) -> Area -> Map (Y,X) Area-grid (ny,nx) ((y0,x0),(y1,x1)) =-  let yd = y1 - y0-      xd = x1 - x0-  in M.fromList [ ((y,x), ((y0 + (yd * y `div` ny), x0 + (xd * x `div` nx)),-                           (y0 + (yd * (y + 1) `div` ny - 1), x0 + (xd * (x + 1) `div` nx - 1))))-                | x <- [0..nx-1], y <- [0..ny-1] ]---connectGrid :: (Y,X) -> Rnd [((Y,X),(Y,X))]-connectGrid (ny,nx) =-  do-    let unconnected = S.fromList [ (y,x) | 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 [ (ry,rx) ]-    connectGrid' (ny,nx) unconnected candidates []--randomConnection :: (Y,X) -> Rnd ((Y,X),(Y,X))-randomConnection (ny,nx) =-  do-    rb  <- randomR (False,True)-    if rb then do-                 rx  <- randomR (0,nx-2)-                 ry  <- randomR (0,ny-1)-                 return (normalize ((ry,rx),(ry,rx+1)))-          else do-                 ry  <- randomR (0,ny-2)-                 rx  <- randomR (0,nx-1)-                 return (normalize ((ry,rx),(ry+1,rx)))--normalize :: ((Y,X),(Y,X)) -> ((Y,X),(Y,X))-normalize (a,b) | a <= b    = (a,b)-                | otherwise = (b,a)--normalizeArea :: Area -> Area-normalizeArea a@((y0,x0),(y1,x1)) = ((min y0 y1, min x0 x1), (max y0 y1, max x0 x1))--connectGrid' :: (Y,X) -> Set (Y,X) -> Set (Y,X) -> [((Y,X),(Y,X))] -> Rnd [((Y,X),(Y,X))]-connectGrid' (ny,nx) unconnected candidates acc-  | S.null candidates = return (L.map normalize acc)-  | otherwise = do-                  c <- oneOf (S.toList candidates)-                  let ns = neighbors ((0,0),(ny-1,nx-1)) c -- potential new candidates-                  let nu = S.delete c unconnected -- new unconnected-                  let (nc,ds) = S.partition (`S.member` nu) ns-                                  -- (new candidates, potential connections)-                  new <- if S.null ds then return id-                                      else do-                                             d <- oneOf (S.toList ds)-                                             return ((c,d) :)-                  connectGrid' (ny,nx) nu-                                       (S.delete c (candidates `S.union` nc)) (new acc)--neighbors :: Area ->        {- size limitation -}-             Loc ->         {- location to find neighbors of -}-             Set Loc-neighbors area (y,x) =-  let cs = [ (y + dy, x + dx) | dy <- [-1..1], dx <- [-1..1], (dx + dy) `mod` 2 == 1 ] -  in  S.fromList (L.filter (`inside` area) cs)--inside :: Loc -> Area -> Bool-inside (y,x) ((y0,x0),(y1,x1)) = x1 >= x && x >= x0 && y1 >= y && y >= y0---fromTo :: Loc -> Loc -> [Loc]-fromTo (y0,x0) (y1,x1)-  | y0 == y1 = L.map (\ x -> (y0,x)) (fromTo1 x0 x1)-  | x0 == x1 = L.map (\ y -> (y,x0)) (fromTo1 y0 y1)--fromTo1 :: X -> X -> [X]-fromTo1 x0 x1-  | x0 <= x1  = [x0..x1]-  | otherwise = [x0,x0-1..x1]--viewTile :: Bool -> Tile -> Assocs -> (Char, Attr -> Attr)-viewTile b (Tile t [])    a = viewTerrain 0 b t -viewTile b (Tile t (i:_)) a = viewItem (itype i) a---- | Produces a textual description of the items at a location. It's--- probably correct to use 'at' rather than 'rememberAt' at this point,--- although we could argue that 'rememberAt' reflects what the player can--- perceive more correctly ...------ The "detailed" variant is for use with an explicit look command.-lookAt :: Bool -> Assocs -> Discoveries -> LMap -> Loc -> String-lookAt detailed a d lvl loc-  | detailed  = lookTerrain (tterrain (lvl `at` loc)) ++ " " ++ isd-  | otherwise = isd-  where-    is  = titems (lvl `at` loc)-    isd = case is of-            []    -> ""-            [i]   -> "You see " ++ objectItem a d (icount i) (itype i) ++ "."-            [i,j] -> "You see " ++ objectItem a d (icount i) (itype i) ++ " and "-                                ++ objectItem a d (icount j) (itype j) ++ "."-            _     -> "There are several objects here" ++-                     if detailed then ":" else "."---- | Produces a textual description for terrain, used if no objects--- are present.-lookTerrain :: Terrain -> String-lookTerrain (Floor _)          = "Floor."-lookTerrain Corridor           = "Corridor."-lookTerrain (Opening _)        = "An opening."-lookTerrain (Stairs _ Up _)    = "A staircase up."-lookTerrain (Stairs _ Down _)  = "A staircase down."-lookTerrain (Door _ Nothing)   = "An open door."-lookTerrain _                  = ""---- | The parameter "n" is the level of evolution:------ 0: final--- 1: stairs added--- 2: doors added--- 3: corridors and openings added--- 4: only rooms------ The Bool indicates whether the loc is currently visible.-viewTerrain :: Int -> Bool -> Terrain -> (Char, Attr -> Attr)-viewTerrain n b Rock              = (' ', id)-viewTerrain n b (Opening d)-  | n <= 3                        = ('.', id)-  | otherwise                     = viewTerrain 0 b (Wall d)-viewTerrain n b (Floor Light)     = ('.', id)-viewTerrain n b (Floor Dark)      = if b then ('.', id) else (' ', id)-viewTerrain n b Unknown           = (' ', id)-viewTerrain n b Corridor-  | n <= 3                        = ('#', id)-  | otherwise                     = viewTerrain 0 b Rock-viewTerrain n b (Wall p)-  | p `elem` [L, R]               = ('|', id)-  | otherwise                     = ('-', id)-viewTerrain n b (Stairs _ Up _)-  | n <= 1                        = ('<', id)-  | otherwise                     = viewTerrain 0 b (Floor Dark)-viewTerrain n b (Stairs _ Down _)-  | n <= 1                        = ('>', id)-  | otherwise                     = viewTerrain 0 b (Floor Dark)-viewTerrain n b (Door d (Just 0))-  | n <= 2                        = ('+', setFG yellow)-  | otherwise                     = viewTerrain n b (Opening d)-viewTerrain n b (Door d (Just _))-  | n <= 2                        = viewTerrain n b (Wall d) -- secret door-  | otherwise                     = viewTerrain n b (Opening d)-viewTerrain n b (Door p Nothing)-  | n <= 2                        = (if p `elem` [L, R] then '-' else '|', setFG yellow)-  | otherwise                     = viewTerrain n b (Opening p)--viewSmell :: Int -> (Char, Attr -> Attr)-viewSmell n = let k | n > 9    = '*'-                    | n < 0    = '-'-                    | otherwise = head . show $ n-              in  (k, setFG black . setBG green)-
− Message.hs 
@@ -1,28 +0,0 @@-module Message where--import Data.List as L-import Data.Char--type Message = String--more :: Message-more = " --more--"--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   -
− Monster.hs 
@@ -1,147 +0,0 @@-module Monster where--import Data.Char-import Data.Binary-import Control.Monad--import Geometry-import Display-import Item-import Random---- | Hit points of the player. TODO: Should not be hardcoded.-playerHP :: Int-playerHP = 20---- | Time the player can be traced by monsters. TODO: Make configurable.-smellTimeout :: Time-smellTimeout = 1000---- | Initial player.-defaultPlayer :: Loc -> Player-defaultPlayer ploc =-  Monster Player playerHP Nothing ploc [] 'a' 10 0--type Player = Monster--data Monster = Monster-                { mtype   :: !MonsterType,-                  mhp     :: !Int,-                  mdir    :: Maybe Dir,  -- for monsters: the dir the monster last moved;-                                         -- for the player: the dir the player is running-                  mloc    :: !Loc,-                  mitems  :: [Item],     -- inventory-                  mletter :: !Char,      -- next inventory letter-                  mspeed  :: !Time,      -- speed (i.e., delay before next action)-                  mtime   :: !Time }     -- time of next action-  deriving Show--instance Binary Monster where-  put (Monster mt mhp md ml minv mletter mspeed mtime) =-    do-      put mt-      put mhp-      put md-      put ml-      put minv-      put mletter-      put mspeed-      put mtime-  get = do-          mt      <- get-          mhp     <- get-          md      <- get-          ml      <- get-          minv    <- get-          mletter <- get-          mspeed  <- get-          mtime   <- get-          return (Monster mt mhp md ml minv mletter mspeed mtime)--data MonsterType =-    Player-  | Eye-  | FastEye-  | Nose-  deriving (Show, Eq)--instance Binary MonsterType where-  put Player  = putWord8 0 -  put Eye     = putWord8 1-  put FastEye = putWord8 2-  put Nose    = putWord8 3-  get = do-          tag <- getWord8-          case tag of-            0 -> return Player -            1 -> return Eye-            2 -> return FastEye-            3 -> return Nose-            _ -> fail "no parse (MonsterType)" --monsterFrequency :: Frequency MonsterType-monsterFrequency =-  Frequency-  [ -    (2, Nose),-    (6, Eye),-    (1, FastEye)-  ]---- | Generate monster.-newMonster :: Loc -> Frequency MonsterType -> Rnd Monster-newMonster loc ftp =-    do-      tp <- frequency ftp-      hp <- hps tp-      let s = speed tp-      return (template tp hp loc s)-  where-    -- 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 tp hp loc s = Monster tp hp Nothing loc [] 'a' s 0-    -    hps Eye      = randomR (1,3)-    hps FastEye  = randomR (1,3)-    hps Nose     = randomR (2,3)--    speed Eye      = 10-    speed FastEye  = 3-    speed Nose     = 11---- | Insert a monster in an mtime-sorted list of monsters.--- Returns the position of the inserted monster and the new list.-insertMonster :: Monster -> [Monster] -> (Int, [Monster])-insertMonster = insertMonster' 0-  where-    insertMonster' n m []      = (n, [m])-    insertMonster' n m (m':ms)-      | mtime m <= mtime m'    = (n, m : m' : ms)-      | otherwise              = let (n', ms') = insertMonster' (n + 1) m ms-                                 in  (n', m' : ms')---objectMonster :: MonsterType -> String-objectMonster Player  = "you"-objectMonster Eye     = "the reducible eye"-objectMonster FastEye = "the super-fast eye"-objectMonster Nose    = "the point-free nose"--subjectMonster :: MonsterType -> String-subjectMonster x = let (s:r) = objectMonster x in toUpper s : r--verbMonster :: MonsterType -> String -> String-verbMonster Player v = v-verbMonster _      v = v ++ "s"--compoundVerbMonster :: MonsterType -> String -> String -> String-compoundVerbMonster Player v p = v ++ " " ++ p-compoundVerbMonster _      v p = v ++ "s " ++ p--viewMonster :: MonsterType -> (Char, Attr -> Attr)-viewMonster Player  = ('@', setBG white . setFG black)-viewMonster Eye     = ('e', setFG red)-viewMonster FastEye = ('e', setFG blue)-viewMonster Nose    = ('n', setFG green)
+ PLAYING.markdown view
@@ -0,0 +1,111 @@+Playing LambdaHack+==================++Playing the game consist of walking around the dungeon and bumping+into things (doors, monsters, treasure). 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, right now you need a lot of imagination, since the game+is very basic, though playable and winnable. Contributions welcome.+++Dungeon+-------++The goal of the hero is to explore the dungeon from top to the very bottom+(and grab lots of shiny treasure and gear on the way).+The dungeon consists of 10 levels and each level consists of 80 by 21 tiles.+The basic tiles tiles are as follows:++               dungeon terrain type               on-screen symbol+               floor                              .+               wall (horizontal and vertical)     - and |+               corridor                           #+               stairs (up and down)               < and >+               closed door                        ++               rock                               blank++The game world is persistent, i.e., every time the hero visits a level+during one game, the level should look the same.+++Keys+----++Here are a few keys you can use in the game:++               key    command+               c      close a door+               d      drop an object+               i      display inventory+               o      open a door+               s      search for secret doors+               q      quaff a potion+               M      display previous messages+               S      save and quit the game+               Q      quit without saving+               .      wait+               ,      pick up an object+               :      look around+               <      ascend a level+               >      descend a level++One of the ways of moving throughout the level is with the vi text editor keys+(also known as "Rogue-like keys"):++               key    command+               k      up+               j      down+               h      left+               l      right+               y      up-left+               u      up-right+               b      down-left+               n      down-right++Pressing a capital letter corresponding to a direction key will have+the hero run in that direction until something interesting occurs.++It's also possible to move using the numerical keypad, with Shift for running+and the middle '5' key for resting. (If you are using the curses frontend,+numerical keypad may not work correctly for terminals with broken terminfo,+e.g., gnome terminal tends to have problems, while xterm works fine.)++Below are also some debug and cheat keys. Use at your peril!++               key    command+               v      display the version of the game+               O      toggle "omniscience"+               I      display level meta-data+               R      toggle smell display+               T      toggle level generation sequence+               V      toggle field of vision display+++Monsters+--------++The hero is not alone in the dungeon. Monsters roam the game world, too.+Monsters inhabit specific locations on the game map, and can be seen+if the tile they are on can be seen by the hero.+Every monster gets a turn per move of the hero. Monster moves+are restricted in the same way as hero moves, i.e., they cannot move+into obstacles like walls or rock. Some monsters+ignore the hero, others chase him only when they see him+and the especially dangerous kind is able to smell the hero.++When the hero moves into a monster or a monster bumps into the hero,+combat occurs. Whenever combat occurs, the attacked party may lose some health.+If the hero dies, the game ends.+++On Winning and Dying+--------------------++If you happen to die, you are free to start again from the first level+of the dungeon, but all your treasure is gone and the dungeon will look+different this time.++You win the game if you escape the dungeon alive with treasure and valuable+items --- the more the better!
− Perception.hs 
@@ -1,48 +0,0 @@-module Perception where--import Data.Set as S--import Geometry-import State-import Level-import Monster-import FOV--data Perception =-  Perception { preachable :: Set Loc, pvisible :: Set Loc }--perception_ :: State -> Level -> Perception-perception_ (State { splayer = Monster { mloc = ploc } }) (Level { lmap = lmap }) =-  perception ploc lmap--perception :: Loc -> LMap -> Perception-perception ploc lmap =-  let-    -- This part is simple. "reachable" contains everything that is on an-    -- unblocked path from the player position.-    reachable  = fullscan ploc lmap-    -- In "actVisible", we store the locations that have light and are-    -- reachable. Furthermore, the player location itself is always-    -- visible.-    actVisible = S.filter (\ loc -> light (lmap `at` loc)) reachable `S.union` S.singleton ploc-    srnd       = S.fromList $ surroundings ploc-    -- In "dirVisible", we store locations in the surroundings that are-    -- perceptible from the current position.-    dirVisible = S.filter (\ loc -> let p = perceptible (lmap `at` loc) :: [Dir]-                                    in  any (\ d -> shift loc d == ploc) p)-                          (S.fromList $ surroundings ploc)-    ownVisible = S.union actVisible dirVisible-    -- Something is "pasVisible" if it is reachable passively visible from an-    -- "actVisible" location, *or* if it is in the surroundings and passively-    -- visible from a "dirVisible" location. (This is complicated, and I'd-    -- like to simplify it, but for now, it seems to at least do what I-    -- want.)-    pasVisible = S.filter (\ loc -> let p = passive (lmap `at` loc)-                                        dp = S.member loc srnd-                                        s = if dp then ownVisible else actVisible-                                    in  any (\ d -> S.member (shift loc d) s) p)-                          reachable-    visible = S.unions [pasVisible, actVisible, dirVisible]-  in-    Perception reachable visible-
− README 
@@ -1,12 +0,0 @@--Installation via Cabal.--There are three displays to choose from, depending on-the flags passed to Setup configure:--  * gtk2hs  (the default)-  * vty     (Setup configure -f-gtk)-  * curses  (Setup configure -fcurses)--The curses display is the newest and least tested,-the other two should be stable.
+ README.markdown view
@@ -0,0 +1,37 @@+LambdaHack+==========++LambdaHack is a small [roguelike] [1] game written in [Haskell] [2].+++Compilation and installation+----------------------------++The game is best compiled and installed via Cabal, which also takes care+of all dependencies. The latest official version of the game can be downloaded+automatically by Cabal from [Hackage] [3] as follows++    cabal install LambdaHack++For a more current snapshot, download the source from [github] [4]+and run Cabal from the main directory++    cabal install++or you may try one of the terminal frontends with++    cabal install -fvty+++Further information+-------------------++See files PLAYING.markdown, DESIGN.markdown, CREDITS and LICENSE+for more information.++++[1]: http://roguebasin.roguelikedevelopment.org/index.php?title=Berlin_Interpretation+[2]: http://www.haskell.org/+[3]: http://hackage.haskell.org/package/LambdaHack+[4]: http://github.com/kosmikus/LambdaHack
− Random.hs 
@@ -1,67 +0,0 @@-module Random (module Frequency, module Random) where--import Data.Ratio-import qualified System.Random as R-import Control.Monad.State--import Frequency--type Rnd a = State R.StdGen a--randomR :: (R.Random a) => (a, a) -> Rnd a-randomR = State . R.randomR--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)---- | d for die/dice-d :: Int -> Rnd Int-d x = 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 xs) =-  do-    r <- randomR (1, sum (map fst xs))-    return (frequency' r xs)- where-  frequency' :: Int -> [(Int, a)] -> a-  frequency' _ [(_, x)] = x-  frequency' m ((n, x) : xs)-    | m <= n            = x-    | otherwise         = frequency' (m - n) xs--rndToIO :: Rnd a -> IO a-rndToIO r =-  do-    g <- R.getStdGen-    let (x,g') = runState r g-    R.setStdGen g'-    return x---- ** 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)
− Save.hs 
@@ -1,34 +0,0 @@-module Save where--import System.Directory-import Control.Exception as E hiding (handle)--import File-import Level-import State---- | Name of the save game. TODO: It should be possible to play--- multiple games next to each other (for instance, in a multi-user--- environment), so the savegames should contain the character name--- and the user id or something like that.-savefile = "LambdaHack.save"---- | We save a simple serialized version of the current level and--- the current state. The 'False' is used only as an EOF marker.-saveGame :: Level -> State -> IO ()-saveGame lvl state = encodeCompressedFile savefile (lvl,state,False)---- | Restore a saved game. Returns either the current level and--- game state, or a string containing an error message if restoring--- the game fails.-restoreGame :: IO (Either (Level, State) String)-restoreGame =-  E.catch (do-             r <- strictDecodeCompressedFile savefile-             removeFile savefile-             case r of-               (x,y,z) -> (z :: Bool) `seq` return $ Left (x,y))-          (\ e -> case e of-                    _ -> return (Right $ "Restore failed: " ++-                                 (unwords . lines) (show e)))-
− State.hs 
@@ -1,116 +0,0 @@-module State where--import qualified Data.Map as M-import qualified Data.Set as S-import Control.Monad-import Data.Binary--import Monster-import Geometry-import Level-import Item---- | The 'State' contains all the game state except the current dungeon--- level which we usually keep separate.-data State = State-               { splayer      :: Monster,-                 shistory     :: [String],-                 ssensory     :: SensoryMode,-                 sdisplay     :: DisplayMode,-                 stime        :: Time,-                 sassocs      :: Assocs,       -- ^ how does every item appear-                 sdiscoveries :: Discoveries,  -- ^ items (types) have been discovered-                 sdungeon     :: Dungeon       -- ^ all but current dungeon level-               }-  deriving Show--defaultState ploc dng =-  State-    (defaultPlayer ploc)-    []-    Implicit Normal-    0-    M.empty-    S.empty-    dng--updatePlayer :: State -> (Monster -> Monster) -> State-updatePlayer s f = s { splayer = f (splayer s) }--updateHistory :: State -> ([String] -> [String]) -> State-updateHistory s f = s { shistory = f (shistory s) }--updateDiscoveries :: State -> (Discoveries -> Discoveries) -> State-updateDiscoveries s f = s { sdiscoveries = f (sdiscoveries s) }--toggleVision :: State -> State-toggleVision s = s { ssensory = if ssensory s == Vision then Implicit else Vision }--toggleSmell :: State -> State-toggleSmell s = s { ssensory = if ssensory s == Smell then Implicit else Smell }--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 hst sense disp time assocs discs dng) =-    do-      put player-      put hst-      put sense-      put disp-      put time-      put assocs-      put discs-      put dng-  get =-    do-      player <- get-      hst    <- get-      sense  <- get-      disp   <- get-      time   <- get-      assocs <- get-      discs  <- get-      dng    <- get-      return (State player hst sense disp time assocs discs dng)--data SensoryMode =-    Implicit-  | Vision-  | Smell-  deriving (Show, Eq)--instance Binary SensoryMode where-  put Implicit = putWord8 0-  put Vision   = putWord8 1-  put Smell    = putWord8 2-  get = do-          tag <- getWord8-          case tag of-            0 -> return Implicit-            1 -> return Vision-            2 -> return Smell-            _ -> fail "no parse (SensoryMode)"--data DisplayMode =-    Normal-  | Omniscient-  | Terrain Int-  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 -> liftM Terrain get-            _ -> fail "no parse (DisplayMode)"-
− Strategy.hs 
@@ -1,49 +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 [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
− Style.hs 
@@ -1,355 +0,0 @@--- --- Copyright (c) 2004-2008 Don Stewart - http://www.cse.unsw.edu.au/~dons--- --- This program is free software; you can redistribute it and/or--- modify it under the terms of the GNU General Public License as--- published by the Free Software Foundation; either version 2 of--- the License, or (at your option) any later version.--- --- This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU--- General Public License for more details.--- --- You should have received a copy of the GNU General Public License--- along with this program; if not, write to the Free Software--- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA--- 02111-1307, USA.--- ------- | Color manipulation-----module Style where--#include "config.h"--import qualified Curses-import Data.ByteString (ByteString)--import Data.Char                (toLower)-import Data.Word                (Word8)-import Data.Maybe               (fromJust)-import Data.IORef               (readIORef, writeIORef, newIORef, IORef)-import qualified Data.Map as M  (fromList, empty, lookup, Map)--import System.IO.Unsafe         (unsafePerformIO)-import Control.Exception        (handle)------------------------------------------------------------------------------ | User-configurable colours--- Each component of this structure corresponds to a fg\/bg colour pair--- for an item in the ui-data UIStyle = UIStyle {-     window      :: !Style  -- default window colour-   , helpscreen  :: !Style  -- help screen-   , titlebar    :: !Style  -- titlebar of window-   , selected    :: !Style  -- currently playing track-   , cursors     :: !Style  -- the scrolling cursor line-   , combined    :: !Style  -- the style to use when the cursor is on the current track-   , warnings    :: !Style  -- style for warnings-   , blockcursor :: !Style  -- style for the block cursor when typing text-   , progress    :: !Style  -- style for the progress bar-   }------------------------------------------------------------------------------ | Colors -data Color-    = RGB {-# UNPACK #-} !Word8 !Word8 !Word8-    | Default-    | Reverse-    deriving (Eq,Ord)---- | Foreground and background color pairs-data Style = Style {-# UNPACK #-} !Color !Color -    deriving (Eq,Ord)---- | A list of such values (the representation is optimised)-data StringA -    = Fast   {-# UNPACK #-} !ByteString !Style-    | FancyS {-# UNPACK #-} ![(ByteString,Style)]  -- one line made up of segments-------------------------------------------------------------------------------- | Some simple colours (derivied from proxima\/src\/common\/CommonTypes.hs)------ But we don't have a light blue?----black, grey, darkred, red, darkgreen, green, brown, yellow          :: Color-darkblue, blue, purple, magenta, darkcyan, cyan, white, brightwhite :: Color-black       = RGB 0 0 0-grey        = RGB 128 128 128-darkred     = RGB 139 0 0-red         = RGB 255 0 0-darkgreen   = RGB 0 100 0-green       = RGB 0 128 0-brown       = RGB 165 42 42-yellow      = RGB 255 255 0-darkblue    = RGB 0 0 139-blue        = RGB 0 0 255-purple      = RGB 128 0 128-magenta     = RGB 255 0 255-darkcyan    = RGB 0 139 139 -cyan        = RGB 0 255 255-white       = RGB 165 165 165-brightwhite = RGB 255 255 255--defaultfg, defaultbg, reversefg, reversebg :: Color-#if defined(HAVE_USE_DEFAULT_COLORS)-defaultfg   = Default-defaultbg   = Default-#else-defaultfg   = white-defaultbg   = black-#endif-reversefg   = Reverse-reversebg   = Reverse------- | map strings to colors----stringToColor :: String -> Maybe Color-stringToColor s = case map toLower s of-    "black"         -> Just black-    "grey"          -> Just grey-    "darkred"       -> Just darkred-    "red"           -> Just red-    "darkgreen"     -> Just darkgreen-    "green"         -> Just green-    "brown"         -> Just brown-    "yellow"        -> Just yellow-    "darkblue"      -> Just darkblue-    "blue"          -> Just blue-    "purple"        -> Just purple-    "magenta"       -> Just magenta-    "darkcyan"      -> Just darkcyan-    "cyan"          -> Just cyan-    "white"         -> Just white-    "brightwhite"   -> Just brightwhite-    "default"       -> Just Default-    "reverse"       -> Just Reverse-    _               -> Nothing-------------------------------------------------------------------------------- | Set some colours, perform an action, and then reset the colours----withStyle :: Style -> (IO ()) -> IO ()-withStyle sty fn = uiAttr sty >>= setAttribute >> fn >> reset-{-# INLINE withStyle #-}------- | manipulate the current attributes of the standard screen--- Only set attr if it's different to the current one?----setAttribute :: (Curses.Attr, Curses.Pair) -> IO ()-setAttribute = uncurry Curses.attrSet-{-# INLINE setAttribute #-}------- | Reset the screen to normal values----reset :: IO ()-reset = setAttribute (Curses.attr0, Curses.Pair 0)-{-# INLINE reset #-}------- | And turn on the colours----initcolours :: UIStyle -> IO ()-initcolours sty = do-    let ls  = [helpscreen sty, warnings sty, window sty, -               selected sty, titlebar sty, progress sty,-               blockcursor sty, cursors sty, combined sty ]-        (Style fg bg) = progress sty    -- bonus style--    pairs <- initUiColors (ls ++ [Style bg bg, Style fg fg])-    writeIORef pairMap pairs-    -- set the background-    uiAttr (window sty) >>= \(_,p) -> Curses.bkgrndSet nullA p-------------------------------------------------------------------------------- | Set up the ui attributes, given a ui style record------ Returns an association list of pairs for foreground and bg colors,--- associated with the terminal color pair that has been defined for--- those colors.----initUiColors :: [Style] -> IO PairMap-initUiColors stys = do -    ls <- sequence [ uncurry fn m | m <- zip stys [1..] ]-    return (M.fromList ls)-  where-    fn :: Style -> Int -> IO (Style, (Curses.Attr,Curses.Pair))-    fn sty p = do-        let (CColor (a,fgc),CColor (b,bgc)) = style2curses sty-        handle (\_ -> return ()) $ Curses.initPair (Curses.Pair p) fgc bgc-        return (sty, (a `Curses.attrPlus` b, Curses.Pair p))-------------------------------------------------------------------------------- | Getting from nice abstract colours to ncurses-settable values---- 20% of allocss occur here! But there's only 3 or 4 colours :/--- Every call to uiAttr----uiAttr :: Style -> IO (Curses.Attr, Curses.Pair)-uiAttr sty = do-    m <- readIORef pairMap-    return $ lookupPair m sty-{-# INLINE uiAttr #-}---- | Given a curses color pair, find the Curses.Pair (i.e. the pair--- curses thinks these colors map to) from the state-lookupPair :: PairMap -> Style -> (Curses.Attr, Curses.Pair)-lookupPair m s = case M.lookup s m of-                    Nothing   -> (Curses.attr0, Curses.Pair 0) -- default settings-                    Just v    -> v-{-# INLINE lookupPair #-}---- | Keep a map of nice style defs to underlying curses pairs, created at init time-type PairMap = M.Map Style (Curses.Attr, Curses.Pair)---- | map of Curses.Color pairs to ncurses terminal Pair settings-pairMap :: IORef PairMap-pairMap = unsafePerformIO $ newIORef M.empty-{-# NOINLINE pairMap #-}-------------------------------------------------------------------------------- Basic (ncurses) colours.----defaultColor :: Curses.Color-defaultColor = fromJust $ Curses.color "default"--cblack, cred, cgreen, cyellow, cblue, cmagenta, ccyan, cwhite :: Curses.Color-cblack     = fromJust $ Curses.color "black"-cred       = fromJust $ Curses.color "red"-cgreen     = fromJust $ Curses.color "green"-cyellow    = fromJust $ Curses.color "yellow"-cblue      = fromJust $ Curses.color "blue"-cmagenta   = fromJust $ Curses.color "magenta"-ccyan      = fromJust $ Curses.color "cyan"-cwhite     = fromJust $ Curses.color "white"------- Combine attribute with another attribute----setBoldA, setReverseA ::  Curses.Attr -> Curses.Attr-setBoldA     = flip Curses.setBold    True-setReverseA  = flip Curses.setReverse True------- | Some attribute constants----boldA, nullA, reverseA :: Curses.Attr-nullA       = Curses.attr0-boldA       = setBoldA      nullA-reverseA    = setReverseA   nullA----------------------------------------------------------------------------newtype CColor = CColor (Curses.Attr, Curses.Color)--- --- | Map Style rgb rgb colours to ncurses pairs--- TODO a generic way to turn an rgb into the nearest curses color----style2curses :: Style -> (CColor, CColor)-style2curses (Style fg bg) = (fgCursCol fg, bgCursCol bg)-{-# INLINE style2curses #-}--fgCursCol :: Color -> CColor-fgCursCol c = case c of-    RGB 0 0 0         -> CColor (nullA, cblack)-    RGB 128 128 128   -> CColor (boldA, cblack)-    RGB 139 0 0       -> CColor (nullA, cred)-    RGB 255 0 0       -> CColor (boldA, cred)-    RGB 0 100 0       -> CColor (nullA, cgreen)-    RGB 0 128 0       -> CColor (boldA, cgreen)-    RGB 165 42 42     -> CColor (nullA, cyellow)-    RGB 255 255 0     -> CColor (boldA, cyellow)-    RGB 0 0 139       -> CColor (nullA, cblue)-    RGB 0 0 255       -> CColor (boldA, cblue)-    RGB 128 0 128     -> CColor (nullA, cmagenta)-    RGB 255 0 255     -> CColor (boldA, cmagenta)-    RGB 0 139 139     -> CColor (nullA, ccyan)-    RGB 0 255 255     -> CColor (boldA, ccyan)-    RGB 165 165 165   -> CColor (nullA, cwhite)-    RGB 255 255 255   -> CColor (boldA, cwhite)-    Default           -> CColor (nullA, defaultColor)-    Reverse           -> CColor (reverseA, defaultColor)-    _                 -> CColor (nullA, cblack) -- NB--bgCursCol :: Color -> CColor-bgCursCol c = case c of-    RGB 0 0 0         -> CColor (nullA, cblack)-    RGB 128 128 128   -> CColor (nullA, cblack)-    RGB 139 0 0       -> CColor (nullA, cred)-    RGB 255 0 0       -> CColor (nullA, cred)-    RGB 0 100 0       -> CColor (nullA, cgreen)-    RGB 0 128 0       -> CColor (nullA, cgreen)-    RGB 165 42 42     -> CColor (nullA, cyellow)-    RGB 255 255 0     -> CColor (nullA, cyellow)-    RGB 0 0 139       -> CColor (nullA, cblue)-    RGB 0 0 255       -> CColor (nullA, cblue)-    RGB 128 0 128     -> CColor (nullA, cmagenta)-    RGB 255 0 255     -> CColor (nullA, cmagenta)-    RGB 0 139 139     -> CColor (nullA, ccyan)-    RGB 0 255 255     -> CColor (nullA, ccyan)-    RGB 165 165 165   -> CColor (nullA, cwhite)-    RGB 255 255 255   -> CColor (nullA, cwhite)-    Default           -> CColor (nullA, defaultColor)-    Reverse           -> CColor (reverseA, defaultColor)-    _                 -> CColor (nullA, cwhite)    -- NB--defaultSty :: Style-defaultSty = Style Default Default-------------------------------------------------------------------------------- Support for runtime configuration--- We choose a simple strategy, read/showable record types, with strings--- to represent colors------ The fields must map to UIStyle------ It is this data type that is stored in 'show' format in ~/.hmp3----data Config = Config {-         hmp3_window      :: (String,String)-       , hmp3_helpscreen  :: (String,String)-       , hmp3_titlebar    :: (String,String)-       , hmp3_selected    :: (String,String)-       , hmp3_cursors     :: (String,String)-       , hmp3_combined    :: (String,String)-       , hmp3_warnings    :: (String,String)-       , hmp3_blockcursor :: (String,String)-       , hmp3_progress    :: (String,String)-     } deriving (Show,Read)------- | Read the ~/.hmp3 file, and construct a UIStyle from it, to insert--- into ----buildStyle :: Config -> UIStyle-buildStyle bs = UIStyle {-         window      = f $ hmp3_window      bs-       , helpscreen  = f $ hmp3_helpscreen  bs-       , titlebar    = f $ hmp3_titlebar    bs-       , selected    = f $ hmp3_selected    bs-       , cursors     = f $ hmp3_cursors     bs-       , combined    = f $ hmp3_combined    bs-       , warnings    = f $ hmp3_warnings    bs-       , blockcursor = f $ hmp3_blockcursor bs-       , progress    = f $ hmp3_progress    bs-    }--    where -        f (x,y) = Style (g x) (g y)-        g x     = case stringToColor x of-                    Nothing -> Default-                    Just y  -> y
− Turn.hs 
@@ -1,621 +0,0 @@-module Turn where--import Data.List as L-import Data.Map as M-import Data.Set as S-import Data.Char-import Data.Maybe-import Data.Function--import State-import Geometry-import Level-import Dungeon-import Monster-import Actor-import Perception-import Item-import Display2-import Random-import Save-import Message-import Version-import Strategy---- | Perform a complete turn (i.e., monster moves etc.)-loop :: Session -> Level -> State -> String -> IO ()-loop session (lvl@(Level nm sz ms smap lmap lmeta))-             (state@(State { splayer = player@(Monster { mhp = php, mloc = ploc }), stime = time }))-             oldmsg =-  do-    -- update smap-    let nsmap = M.insert ploc (time + smellTimeout) smap-    -- determine player perception-    let per = perception ploc lmap-    -- perform monster moves-    handleMonsters session (lvl { lsmell = nsmap }) state per oldmsg---- | Handle monster moves. The idea is that we perform moves---   as long as there are monsters that have a move time which is---   less than or equal to the current time.-handleMonsters :: Session -> Level -> State -> Perception -> String -> IO ()-handleMonsters session lvl@(Level { lmonsters = ms })-               (state@(State { stime = time }))-               per oldmsg =-    -- for debugging: causes redraw of the current state for every monster move; slow!-    -- displayLevel session lvl per state oldmsg >>-    case ms of-      [] -> -- there are no monsters, just continue-            handlePlayer-      (m@(Monster { mtime = mt }) : ms)-         | mt > time  -> -- all the monsters are not yet ready for another move,-                         -- so continue-                            handlePlayer-         | mhp m <= 0 -> -- the monster dies-                            handleMonsters session (updateMonsters lvl (const ms))-                                           state per oldmsg-         | otherwise  -> -- monster m should move-                            handleMonster m session (updateMonsters lvl (const ms))-                                          state per oldmsg-  where-    nstate = state { stime = time + 1 }--    -- good place to do everything that has to be done for every *time*-    -- unit; currently, that's monster generation-    handlePlayer =-      do-        nlvl <- rndToIO (addMonster lvl (splayer nstate))-        handle session nlvl nstate per oldmsg-        ---- | Handle the move of a single monster.-handleMonster :: Monster -> Session -> Level -> State -> Perception -> String ->-                 IO ()-handleMonster m session lvl@(Level { lmonsters = ms, lsmell = nsmap, lmap = lmap })-              (state@(State { splayer = player@(Monster { mloc = ploc }), stime = time }))-              per oldmsg =-  do-    nl <- rndToIO (frequency (head (runStrategy (strategy m lvl state per .| wait))))--    -- increase the monster move time and set direction-    let nm = m { mtime = time + mspeed m, mdir = if nl == (0,0) then Nothing else Just nl }-    let (act, nms) = insertMonster nm ms-    let nlvl = updateMonsters lvl (const nms)-    moveOrAttack-      True-      (\ nlvl np msg ->-         handleMonsters session nlvl (updatePlayer state (const np)) per-                        (addMsg oldmsg msg))-      (handleMonsters session nlvl state per oldmsg)-      nlvl player (sassocs state) (sdiscoveries state) per-      (AMonster act)-      nl--strategy :: Monster -> Level -> State -> Perception -> Strategy Loc-strategy m@(Monster { mtype = mt, mloc = me, mdir = mdir })-         lvl@(Level { lmonsters = ms, lsmell = nsmap, lmap = lmap })-         (state@(State { splayer = player@(Monster { mloc = ploc }), stime = time }))-         per =-    case mt of-      Eye     -> eye-      FastEye -> eye-      Nose    -> nose -      _       -> onlyAccessible moveRandomly-  where-    -- we check if the monster is visible by the player rather than if the-    -- player is visible by the monster -- this is more efficient, but-    -- won't be correct in the general situation-    playerVisible      =  me `S.member` pvisible per-    playerAdjacent     =  adjacent me ploc-    towardsPlayer      =  towards (me, ploc)-    onlyTowardsPlayer  =  only (\ x -> distance (towardsPlayer, x) <= 1)-    onlyPreservesDir   =  only (\ x -> maybe True (\ d -> distance (neg d, x) > 1) mdir) -    onlyUnoccupied     =  onlyMoves (unoccupied ms lmap) me-    onlyAccessible     =  onlyMoves (accessible lmap me) me-    smells             =  L.map fst $-                          L.sortBy (\ (_,s1) (_,s2) -> compare s2 s1) $-                          L.filter (\ (_,s) -> s > 0) $ -                          L.map (\ x -> (x, nsmap ! (me `shift` x) - time `max` 0)) moves--    eye                =  playerAdjacent .=> return towardsPlayer-                          .| (onlyUnoccupied $ onlyAccessible $-                                 playerVisible  .=> onlyTowardsPlayer moveRandomly-                              .| onlyPreservesDir moveRandomly)--    nose               =  playerAdjacent .=> return towardsPlayer-                          .| (onlyAccessible $-                                 foldr (.|) reject (L.map return smells)-                              .| moveRandomly)--onlyMoves :: (Dir -> Bool) -> Loc -> Strategy Dir -> Strategy Dir-onlyMoves p l = only (\ x -> p (l `shift` x))--moveRandomly :: Strategy Dir-moveRandomly = liftFrequency $ uniform moves--wait :: Strategy Dir-wait = return (0,0)---- | Display current status and handle the turn of the player.-handle :: Session -> Level -> State -> Perception -> String -> IO ()-handle session (lvl@(Level nm sz ms smap lmap lmeta))-               (state@(State { splayer = player@(Monster { mhp = php, mdir = pdir, mloc = ploc, mitems = pinv, mtime = ptime }), stime = time, sassocs = assocs, sdiscoveries = discs }))-               per oldmsg =-    -- check for player death-    if php <= 0-      then do-             displayCurrent (addMsg oldmsg ("You die ..." ++ more))-             getConfirm session-             shutdown session-      else -- check if the player can make another move yet-           if ptime > time then-             do-               -- do not make intermediate redraws while running-               maybe (displayLevel session lvl per state "") (const $ return ()) pdir-               handleMonsters session lvl state per oldmsg -           -- NOTE: It's important to call handleMonsters here, not loop,-           -- because loop does all sorts of calculations that are only-           -- really necessary after the player has moved.-      else do-             displayCurrent oldmsg-             let h = nextEvent session >>= h'-                 h' e =-                       handleDirection e (move h) $ -                         handleDirection (L.map toLower e) run $-                         handleModifier e h $-                         case e of-                           "o"       -> openclose True h-                           "c"       -> openclose False h-                           "s"       -> search h--                           "less"    -> lvlchange Up h-                           "greater" -> lvlchange Down h--                           -- items-                           "comma"   -> pickup h-                           "d"       -> drop h-                           "i"       -> inventory h-                           "q"       -> drink h--                           -- saving or ending the game-                           "S"       -> saveGame lvl mstate >> shutdown session-                           "Q"       -> shutdown session-                           "Escape"  -> displayCurrent "Press Q to quit." >> h--                           -- wait-                           "space"   -> loop session nlvl nstate ""-                           "period"  -> loop session nlvl nstate ""--                           -- look-                           "colon"   -> lookAround h--                           -- display modes-                           "V"       -> handle session nlvl (toggleVision state) per oldmsg-                           "R"       -> handle session nlvl (toggleSmell state) per oldmsg-                           "O"       -> handle session nlvl (toggleOmniscient state) per oldmsg-                           "T"       -> handle session nlvl (toggleTerrain state) per oldmsg--                           -- meta information-                           "M"       -> displayCurrent' "" (unlines (shistory mstate) ++ more) >>= \ b ->-                                        if b then getOptionalConfirm session-                                                    (const (displayCurrent "" >> h)) h'-                                             else displayCurrent "" >> h-                           "I"       -> displayCurrent lmeta >> h-                           "v"       -> displayCurrent version >> h--                           s   -> displayCurrent ("unknown command (" ++ s ++ ")") >> h-             maybe h continueRun pdir-- where--  -- we record the oldmsg in the history-  mstate = if L.null oldmsg then state else updateHistory state (take 500 . ((oldmsg ++ " "):))-    -- TODO: make history max configurable--  reachable = preachable per-  visible   = pvisible per--  displayCurrent :: String -> IO ()-  displayCurrent  = displayLevel session nlvl per state--  displayCurrent' :: String -> String -> IO Bool-  displayCurrent' = displayOverlay session nlvl per state--  -- update player memory-  nlmap = foldr (\ x m -> M.update (\ (t,_) -> Just (t,t)) x m) lmap (S.toList visible)-  nlvl = updateLMap lvl (const nlmap)--  -- update player action time, and regenerate hitpoints-  -- player HP regeneration, TODO: remove hardcoded max and time interval-  nplayer = player { mtime = time + mspeed player,-                     mhp   = if time `mod` 1500 == 0 then (php + 1) `min` playerHP else php }-  nstate  = updatePlayer mstate (const nplayer)--  -- picking up items-  pickup abort = pickupItem-                   displayCurrent-                   (\ l p -> loop session l (updatePlayer nstate (const p)))-                   abort-                   nlvl nplayer assocs discs--  -- dropping items-  drop abort = dropItem-                 session-                 displayCurrent-                 displayCurrent'-                 (\ l p -> loop session l (updatePlayer nstate (const p)))-                 abort-                 nlvl nplayer assocs discs--  -- drinking potions-  drink abort = drinkPotion-                  session-                  displayCurrent-                  displayCurrent'-                  (\ l p d -> loop session l-                                (updateDiscoveries (updatePlayer nstate (const p)) (S.union d)))-                  abort-                  nlvl nplayer assocs discs-      -  -- display inventory-  inventory abort -    | L.null (mitems player) =-      displayCurrent "You are not carrying anything." >> abort-    | otherwise =-    do-      displayItems displayCurrent' assocs discs -                   "This is what you are carrying:" True (mitems player)-      getConfirm session-      displayCurrent ""-      abort  -- looking at inventory doesn't take any time-      -  -- look around at current location-  lookAround abort =-    do-      -- check if something is here to pick up-      let t = nlmap `at` ploc-      if length (titems t) <= 2-        then displayCurrent (lookAt True assocs discs nlmap ploc) >> abort-        else-          do-             displayItems displayCurrent' assocs discs-                          (lookAt True assocs discs nlmap ploc) False (titems t)-             getConfirm session-             displayCurrent ""-             abort  -- looking around doesn't take any time--  -- open and close doors-  openclose o abort =-    do-      displayCurrent "direction?"-      e <- nextEvent session-      handleDirection e (openclose' o abort) (displayCurrent "never mind" >> abort)-  openclose' o abort dir =-    let txt  = if o then "open" else "closed"-        dloc = shift ploc dir-    in-      case nlmap `at` dloc of-        Tile d@(Door hv o') is-                   | secret o'   -> displayCurrent "never mind" >> abort-                   | toOpen (not o) /= o'-                                 -> displayCurrent ("already " ++ txt) >> abort-                   | not (unoccupied ms nlmap dloc)-                                 -> displayCurrent "blocked" >> abort-                   | otherwise   -> -- ok, we can open/close the door      -                                    let nt = Tile (Door hv (toOpen o)) is-                                        clmap = M.insert (shift ploc dir) (nt, nt) nlmap-                                    in loop session (updateLMap lvl (const clmap)) nstate ""-        _ -> displayCurrent "never mind" >> abort-  -- search for secret doors-  search abort =-    let searchTile (Tile (Door hv (Just n)) x,t') = Just (Tile (Door hv (Just (max (n - 1) 0))) x, t')-        searchTile t                              = Just t-        slmap = foldl (\ l m -> update searchTile (shift ploc m) l) nlmap moves-    in  loop session (updateLMap lvl (const slmap)) nstate ""-  -- perform a level change-  lvlchange vdir abort =-    case nlmap `at` ploc of-      Tile (Stairs _ vdir' next) is-       | vdir == vdir' -> -- ok-          case next of-            Nothing      -> -- exit dungeon-                            shutdown session-            Just (nln, nloc) ->-              -- perform level change-              do-                -- put back current level-                -- (first put back, then get, in case we change to the same level!)-                let full = putDungeonLevel lvl (sdungeon nstate)-                -- get new level-                    (new, ndng) = getDungeonLevel nln full-                    lstate = nstate { sdungeon = ndng }-                loop session new (updatePlayer lstate (const (player { mloc = nloc }))) ""-      _ -> -- no stairs-           let txt = if vdir == Up then "up" else "down" in-           displayCurrent ("no stairs " ++ txt) >> abort-  -- run into a direction-  run dir =-    do-      let mplayer = nplayer { mdir = Just dir }-          abort   = handle session nlvl (updatePlayer state (const $ player { mdir = Nothing })) per ""-      moveOrAttack-        False   -- attacks are disallowed while running-        (\ l p -> loop session l (updatePlayer nstate (const p)))-        abort-        nlvl mplayer assocs discs per APlayer dir-  continueRun dir =-    let abort = handle session nlvl (updatePlayer state (const $ player { mdir = Nothing })) per oldmsg-        dloc  = shift ploc dir-    in  case (oldmsg, nlmap `at` ploc) of-          (_:_, _)                   -> abort-          (_, Tile (Opening {}) _)   -> abort-          (_, Tile (Door {}) _)      -> abort-          (_, Tile (Stairs {}) _)    -> abort-          _-            | accessible nlmap ploc dloc ->-                moveOrAttack-                  False    -- attacks are disallowed while running-                  (\ l p -> loop session l (updatePlayer nstate (const p)))-                  abort-                  nlvl nplayer assocs discs per APlayer dir-          (_, Tile Corridor _)  -- direction change restricted to corridors-            | otherwise ->-                let ns  = L.filter (\ x -> distance (neg dir,x) > 1-                                        && accessible nlmap ploc (ploc `shift` x)) moves-                    sns = L.filter (\ x -> distance (dir,x) <= 1) ns-                in  case ns of-                      [newdir] -> run newdir-                      _        -> case sns of-                                    [newdir] -> run newdir-                                    _        -> abort-          _ -> abort-  -- perform a player move-  move abort dir = moveOrAttack-                     True   -- attacks are allowed-                     (\ l p -> loop session l (updatePlayer nstate (const p)))-                     abort-                     nlvl nplayer assocs discs per APlayer dir---- | Drinking potions.-drinkPotion ::   Session ->                                    -- session-                 (String -> IO ()) ->                          -- how to display-                 (String -> String -> IO Bool) ->              -- overlay display-                 (Level -> Player -> Discoveries -> String -> IO a) ->     -                                                               -- success continuation-                 IO a ->                                       -- failure continuation-                 Level ->                                      -- the level-                 Player ->                                     -- the player-                 Assocs ->-                 Discoveries ->-                 IO a-drinkPotion session displayCurrent displayCurrent' continue abort-            nlvl@(Level { lmap = nlmap }) nplayer@(Monster { mloc = ploc }) assocs discs-    | L.null (mitems nplayer) =-      displayCurrent "You are not carrying anything." >> abort-    | otherwise =-    do-      i <- getPotions session displayCurrent displayCurrent' assocs discs-                      "What to drink?" (mitems nplayer)-      case i of-        Just i'@(Item { itype = Potion ptype }) ->-                   let iplayer = nplayer { mitems = deleteBy ((==) `on` iletter) i' (mitems nplayer) }-                       t = nlmap `at` ploc-                       msg = subjectMonster (mtype nplayer) ++ " " ++-                             verbMonster (mtype nplayer) "drink" ++ " " ++-                             objectItem assocs discs (icount i') (itype i') ++ ". " ++-                             pmsg ptype-                       pmsg PotionWater   = "Tastes like water."-                       pmsg PotionHealing = "You feel better."-                       fplayer PotionWater   = iplayer-                       fplayer PotionHealing = iplayer { mhp = 20 }-                   in  continue nlvl-                                (fplayer ptype) (S.singleton (itype i')) msg-        Just _  -> displayCurrent "you cannot drink that" >> abort-        Nothing -> displayCurrent "never mind" >> abort----- | Dropping items.-dropItem ::   Session ->                                    -- session-              (String -> IO ()) ->                          -- how to display-              (String -> String -> IO Bool) ->              -- overlay display-              (Level -> Player -> String -> IO a) ->        -- success continuation-              IO a ->                                       -- failure continuation-              Level ->                                      -- the level-              Player ->                                     -- the player-              Assocs ->-              Discoveries ->-              IO a-dropItem session displayCurrent displayCurrent' continue abort-         nlvl@(Level { lmap = nlmap }) nplayer@(Monster { mloc = ploc }) assocs discs-    | L.null (mitems nplayer) =-      displayCurrent "You are not carrying anything." >> abort-    | otherwise =-    do-      i <- getAnyItem session displayCurrent displayCurrent' assocs discs-                      "What to drop?" (mitems nplayer)-      case i of-        Just i' -> let iplayer = nplayer { mitems = deleteBy ((==) `on` iletter) i' (mitems nplayer) }-                       t = nlmap `at` ploc-                       nt = t { titems = snd (joinItem i' (titems t)) }-                       plmap = M.insert ploc (nt, nt) nlmap-                       msg = subjectMonster (mtype nplayer) ++ " " ++-                             verbMonster (mtype nplayer) "drop" ++ " " ++-                             objectItem assocs discs (icount i') (itype i') ++ "."-                   in  continue (updateLMap nlvl (const plmap))-                                iplayer msg-        Nothing -> displayCurrent "never mind" >> abort------- | Picking up items.-pickupItem :: (String -> IO ()) ->                          -- how to display-              (Level -> Player -> String -> IO a) ->        -- success continuation-              IO a ->                                       -- failure continuation-              Level ->                                      -- the level-              Player ->                                     -- the player-              Assocs ->-              Discoveries ->-              IO a-pickupItem displayCurrent continue abort-           nlvl@(Level { lmap = nlmap }) nplayer@(Monster { mloc = ploc }) assocs discs =-    do-      -- check if something is here to pick up-      let t = nlmap `at` ploc-      case titems t of-        []      ->  displayCurrent "nothing here" >> abort-        (i:rs)  ->  -          case assignLetter (iletter i) (mletter nplayer) (mitems nplayer) of-            Just l  ->-              let msg = -- (complete sentence, more adequate for monsters)-                        {--                        subjectMonster (mtype player) ++ " " ++-                        compoundVerbMonster (mtype player) "pick" "up" ++ " " ++-                        objectItem (icount i) (itype i) ++ "."-                        -}-                        letterLabel (iletter ni) ++ objectItem assocs discs (icount ni) (itype ni)-                  nt = t { titems = rs }-                  plmap = M.insert ploc (nt, nt) nlmap-                  (ni,nitems) = joinItem (i { iletter = Just l }) (mitems nplayer)-                  iplayer = nplayer { mitems  = nitems,-                                      mletter = maxLetter l (mletter nplayer) }-              in  continue (updateLMap nlvl (const plmap))-                           iplayer msg-            Nothing -> displayCurrent "cannot carry anymore" >> abort--getPotions :: Session ->-              (String -> IO ()) ->-              (String -> String -> IO Bool) ->-              Assocs ->-              Discoveries ->-              String ->-              [Item] ->-              IO (Maybe Item)-getPotions session displayCurrent displayCurrent' assocs discs prompt is =-  getItem session displayCurrent displayCurrent' assocs discs-          prompt (\ i -> case itype i of Potion {} -> True; _ -> False)-          "Potions in your inventory:" is--getAnyItem :: Session ->-              (String -> IO ()) ->-              (String -> String -> IO Bool) ->-              Assocs ->-              Discoveries ->-              String ->-              [Item] ->-              IO (Maybe Item)-getAnyItem session displayCurrent displayCurrent' assocs discs prompt is =-  getItem session displayCurrent displayCurrent' assocs discs-          prompt (const True) "Objects in your inventory:" is--getItem :: Session ->-           (String -> IO ()) ->-           (String -> String -> IO Bool) ->-           Assocs ->-           Discoveries ->-           String ->-           (Item -> Bool) ->-           String ->-           [Item] ->-           IO (Maybe Item) -getItem session displayCurrent displayCurrent' assocs discs prompt p ptext is0 =-  let is = L.filter p is0-      choice | L.null is = "[*]"-             | otherwise = "[" ++ letterRange (concatMap (maybeToList . iletter) is) ++ " or ?*]"-      r = do-            displayCurrent (prompt ++ " " ++ choice)-            let h = nextEvent session >>= h'-                h' e =-                    handleModifier e h $-                      case e of-                        "question" -> do-                                        b <- displayItems displayCurrent' assocs discs-                                                          ptext True is-                                        if b then getOptionalConfirm session (const r) h'-                                             else r -                        "asterisk" -> do-                                        b <- displayItems displayCurrent' assocs discs-                                                          "Objects in your inventory:" True is0-                                        if b then getOptionalConfirm session (const r) h'-                                             else r-                        [l]        -> return (find (\ i -> maybe False (== l) (iletter i)) is0)-                        _          -> return Nothing-            h-  in r--displayItems displayCurrent' assocs discs msg sorted is =-    do-      let inv = unlines $-                L.map (\ (Item { icount = c, iletter = l, itype = t }) -> -                         letterLabel l ++ objectItem assocs discs c t ++ " ")-                      ((if sorted then sortBy (cmpLetter' `on` iletter) else id) is)-      let ovl = inv ++ more-      displayCurrent' msg ovl---moveOrAttack :: Bool ->                                     -- allow attacks?-                (Level -> Player -> String -> IO a) ->      -- success continuation-                IO a ->                                     -- failure continuation-                Level ->                                    -- the level-                Player ->                                   -- the player-                Assocs ->-                Discoveries ->-                Perception ->                               -- perception of the player-                Actor ->                                    -- who's moving?-                Dir -> IO a-moveOrAttack allowAttacks-             continue abort-             nlvl@(Level { lmap = nlmap }) player assocs discs per-             actor dir-      -- to prevent monsters from hitting themselves-    | dir == (0,0) = continue nlvl player ""-      -- At the moment, we check whether there is a monster before checking accessibility-      -- i.e., we can attack a monster on a blocked location. For instance,-      -- a monster on an open door can be attacked diagonally, and a-      -- monster capable of moving through walls can be attacked from an-      -- adjacent position.-    | not (L.null attacked) =-        if allowAttacks then-          do-            let damage m = case mhp m of-                             1  ->  m { mhp = 0, mtime = 0 }  -- grant an immediate move to die-                             h  ->  m { mhp = h - 1 }-            let combatVerb m-                  | mhp m > 0 = "hit"-                  | otherwise = "kill"-            let combatMsg m  = subjectMonster (mtype am) ++ " " ++-                               verbMonster (mtype am) (combatVerb m) ++ " " ++-                               objectMonster (mtype m) ++ "."-            let perceivedMsg m-                  | mloc m `S.member` pvisible per = combatMsg m-                  | otherwise                      = "You hear some noises."-            let sortmtime = sortBy (\ x y -> compare (mtime x) (mtime y))-            let updateVictims l p msg (a:r) =-                  updateActor damage (\ m l p -> updateVictims l p-                                                   (addMsg msg (perceivedMsg m)) r)-                              a l p-                updateVictims l p msg [] = continue l {- (updateMonsters l sortmtime) -} p msg-            updateVictims nlvl player "" attacked-        else-          abort-      -- Perform a move.-    | accessible nlmap aloc naloc = -        updateActor (\ m -> m { mloc = naloc })-                    (\ _ l p -> continue l p (if actor == APlayer-                                              then lookAt False assocs discs nlmap naloc else ""))-                    actor nlvl player-    | otherwise = abort-    where am :: Monster-          am     = getActor nlvl player actor-          aloc :: Loc-          aloc   = mloc am-          source = nlmap `at` aloc-          naloc  = shift aloc dir-          target = nlmap `at` naloc-          attackedPlayer   = [ APlayer | mloc player == naloc ]-          attackedMonsters = L.map AMonster $-                             findIndices (\ m -> mloc m == naloc) (lmonsters nlvl)-          attacked :: [Actor]-          attacked         = attackedPlayer ++ attackedMonsters--
− Version.hs 
@@ -1,12 +0,0 @@-module Version where--import Data.Version---- Cabal-import qualified Paths_LambdaHack as Self (version)--import Display--version :: String-version = showVersion Self.version ++ " (" ++ displayId ++ " frontend)"-
+ src/Action.hs view
@@ -0,0 +1,194 @@+{-# LANGUAGE MultiParamTypeClasses, RankNTypes #-}+module Action where++import Control.Monad+import Control.Monad.State hiding (State)+-- import System.IO (hPutStrLn, stderr) -- just for debugging++import Perception+import Display2 hiding (display)+import Message+import State++newtype Action a = Action+  { runAction ::+      forall r .+      Session ->+      IO r ->                                          -- shutdown cont+      Perception ->                                    -- cached perception+      (State -> Message -> a -> IO r) ->               -- continuation+      IO r ->                                          -- failure/reset cont+      State ->                                         -- current state+      Message ->                                       -- current message+      IO r+  }++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 session state msg h =+  runAction h+    session+    (shutdown session)         -- get out of the game+    (perception_ state)        -- cached perception+    (\ _ _ x -> return x)      -- final continuation returns result+    (ioError $ userError "unhandled abort")+    state+    msg++-- | 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 the current message.+display :: Action Bool+display = Action (\ s e p k a st ms -> displayLevel s p st ms Nothing >>= k st ms)++-- | Display an overlay on top of the current screen.+overlay :: String -> Action Bool+overlay txt = Action (\ s e p k a st ms -> displayLevel s p st ms (Just txt) >>= k st ms)++-- | Set the current message.+message :: Message -> Action ()+message 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.+resetMessage :: Action Message+resetMessage = Action (\ s e p k a st ms -> k st "" ms)++-- | 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+    message msg+    display+    abort++-- | Abort, and print the given message if the condition is true.+abortIfWith :: Bool -> Message -> Action a+abortIfWith True  = abortWith+abortIfWith False = const abort++-- | Print message, await confirmation. Return value indicates if the+-- player tried to abort/escape.+messageMoreConfirm :: Message -> Action Bool+messageMoreConfirm msg =+  do+    message (msg ++ more)+    display+    session getConfirm++-- | Print a yes/no question and return the player's answer.+messageYesNo :: Message -> Action Bool+messageYesNo msg =+  do+    message (msg ++ yesno)+    display+    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+    resetMessage+    display+    return True+messageOverlaysConfirm msg (x:xs) =+  do+    message msg+    b <- overlay (x ++ more)+    if b+      then do+        b <- session getConfirm+        if b+          then do+            messageOverlaysConfirm msg xs+          else stop+      else stop+  where+    stop =+      do+        resetMessage+        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 Perception+currentPerception = Action (\ s e p k a st ms -> k st ms p)+
+ src/Actions.hs view
@@ -0,0 +1,593 @@+module Actions where++import Control.Monad+import Control.Monad.State hiding (State)+import Data.Function+import Data.List as L+import Data.Map as M+import Data.Maybe+import Data.Set as S+import System.Time++import Action+import Actor hiding (updateActor)+import Display2 hiding (display)+import Dungeon+import Geometry+import Grammar+import qualified HighScores as H+import Item+import qualified Keys as K+import Level+import LevelState+import Message+import Monster+import Perception+import Random+import qualified Save as S+import State++displayHistory :: Action ()+displayHistory =+  do+    hst <- gets shistory+    messageOverlayConfirm "" (unlines hst)+    abort++saveGame :: Action ()+saveGame =+  do+    b <- messageYesNo "Really save?"+    if b+      then do+        -- Save the game state+        st <- get+        liftIO $ S.saveGame st+        let total = calculateTotal (splayer st)+        handleScores False False False total+        end+      else abortWith "Game resumed."++quitGame :: Action ()+quitGame =+  do+    b <- messageYesNo "Really quit?"+    if b+      then end -- TODO: why no highscore?+      else abortWith "Game resumed."++move :: Dir -> Action ()+move = moveOrAttack True True APlayer++run :: Dir -> Action ()+run dir =+  do+    modify (updatePlayer (\ p -> p { mdir = Just dir }))+    moveOrAttack False False APlayer dir -- attacks and opening doors disallowed while running++-- | 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+    state <- get+    let lvl   @(Level   { lmonsters = ms, lmap = lmap }) = slevel  state+    let player@(Monster { mloc = loc })                  = splayer state+    let mslocs = S.fromList (L.map mloc ms)+    let t      = lmap `at` loc  -- tile at current location+    per <- currentPerception+    msg <- currentMessage+    let monstersVisible = not (S.null (mslocs `S.intersection` pvisible per))+    let newsReported    = not (L.null msg)+    let itemsHere       = not (L.null (titems t))+    let dirOK           = accessible lmap loc (loc `shift` dir)+    -- What happens next is mostly depending on the terrain we're currently on.+    let exit (Stairs  {}) = True+        exit (Opening {}) = True+        exit (Door    {}) = True+        exit _            = False+    let hop t+          | monstersVisible || newsReported || itemsHere || exit t = abort+        hop Corridor =+          -- in corridors, explore all corners and stop at all crossings+          let ns = L.filter (\ x -> distance (neg dir, x) > 1+                                    && accessible lmap loc (loc `shift` x))+                            moves+              allCloseTo main = L.all (\ d -> distance (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 (\ x -> not $ diagonal x) ns of+                    [ortoDir]+                      | allCloseTo ortoDir -> run ortoDir+                    _ -> abort+        hop _  -- outside corridors, never change direction+          | not dirOK = abort+        hop _         =+          let ns = L.filter (\ x -> x /= dir && distance (neg dir, x) > 1) moves+              ls = L.map (loc `shift`) ns+              as = L.filter (\ x -> accessible lmap loc x+                                    || openable 0 lmap x) ls+              ts = L.map (tterrain . (lmap `at`)) as+          in  if L.any exit ts then abort else run dir+    hop (tterrain t)++stopRunning :: Action ()+stopRunning = modify (updatePlayer (\ p -> p { mdir = Nothing }))++ifRunning :: (Dir -> Action a) -> Action a -> Action a+ifRunning t e =+  do+    mdir <- gets (mdir . splayer)+    maybe e t mdir++-- | Store current message in the history and reset current message.+history :: Action ()+history =+  do+    msg <- resetMessage+    unless (L.null msg) $+      modify (updateHistory (take 500 . ((msg ++ " "):)))+    -- TODO: make history max configurable++-- | Update player memory.+remember :: Action ()+remember =+  do+    per <- currentPerception+    let vis         = S.toList (pvisible per)+    let rememberLoc = M.update (\ (t,_) -> Just (t,t))+    modify (updateLevel (updateLMap (\ lmap -> foldr rememberLoc lmap vis)))++checkHeroDeath :: Action ()+checkHeroDeath =+  do+    player <- gets splayer+    let php = mhp player+    when (php <= 0) $ do+      messageAdd more+      display+      session getConfirm+      go <- messageMoreConfirm "You die."+      when go $ do+        let total = calculateTotal player+        handleScores True True False total+      end++neverMind :: Bool -> Action a+neverMind b = abortIfWith b "never mind"++-- | Open and close doors+openclose :: Bool -> Action ()+openclose o =+  do+    message "direction?"+    display+    e <- session nextCommand+    handleDirection e (actorOpenClose APlayer True o) (neverMind True)++actorOpenClose :: Actor ->+                  Bool ->    -- ^ verbose?+                  Bool ->    -- ^ open?+                  Dir -> Action ()+actorOpenClose actor v o dir =+  do+    let txt = if o then "open" else "closed"+    state <- get+    let lvl@Level { lmonsters = ms, lmap = lmap } = slevel state+    let loc                                       = mloc (getActor state actor)+    let isPlayer  = actor == APlayer+    let isVerbose = v && isPlayer+    let dloc = shift loc dir  -- location we act upon+      in case lmap `at` dloc of+           Tile d@(Door hv o') []+             | secret o' && isPlayer-> -- door is secret, cannot be opened or closed by hero+                                       neverMind isVerbose+             | toOpen (not o) /= o' -> -- door is in unsuitable state+                                       abortIfWith isVerbose ("already " ++ txt)+             | not (unoccupied ms lmap dloc) ->+                                       -- door is blocked by a monster+                                       abortIfWith isVerbose "blocked"+             | otherwise            -> -- door can be opened / closed+                                       -- TODO: print message if action performed by monster and perceived+                                       let nt    = Tile (Door hv (toOpen o)) []+                                           clmap = M.adjust (\ (_, mt) -> (nt, mt)) dloc lmap+                                       in  modify (updateLevel (const (updateLMap (const clmap) lvl)))+           Tile d@(Door hv o') _    -> -- door is jammed by items+                                       abortIfWith isVerbose "jammed"+           _                        -> -- there is no door here+                                       neverMind isVerbose++-- | Perform a level change -- will quit the game if the player leaves+-- the dungeon.+lvlchange :: VDir -> Action ()+lvlchange vdir =+  do+    state <- get+    let lvl   @(Level   { lmap = lmap }) = slevel  state+    let player@(Monster { mloc = ploc }) = splayer state+    case lmap `at` ploc of+      Tile (Stairs _ vdir' next) is+        | vdir == vdir' -> -- stairs are in the right direction+          case next of+            Nothing ->+              -- we are at the "end" of the dungeon+              fleeDungeon+            Just (nln, nloc) ->+              -- perform level change+              do+                -- put back current level+                -- (first put back, then get, in case we change to the same level!)+                let full = putDungeonLevel lvl (sdungeon state)+                -- get new level+                let (new, ndng) = getDungeonLevel nln full+                modify (\ s -> s { sdungeon = ndng, slevel = new })+                modify (updatePlayer (\ p -> p { mloc = nloc }))+      _ -> -- no stairs+        do+          let txt = if vdir == Up then "up" else "down"+          abortWith ("no stairs " ++ txt)++-- | Hero has left the dungeon.+fleeDungeon :: Action ()+fleeDungeon =+  do+    player@(Monster { mitems = items }) <- gets splayer+    let total = calculateTotal player+    if total == 0+      then do+             messageMoreConfirm "Coward!"+             messageMoreConfirm "Next time try to grab some loot before you flee!"+             end+      else do+             let winMsg = "Congratulations, you won! Your loot, worth " +++                          show total ++ " gold, is:"+             displayItems winMsg True items+             go <- session getConfirm+             when go $ handleScores True False True total+             end++-- | Calculate loot's worth. TODO: move to another module, and refine significantly.+calculateTotal :: Player -> Int+calculateTotal player = L.sum $ L.map price $ mitems player+  where+    price i = if iletter i == Just '$' then icount i else 10 * icount i++-- | Handle current score and display it with the high scores. TODO: simplify. Scores+-- should not be shown during the game, because ultimately the worth of items might give+-- information about the nature of the items.+handleScores :: Bool -> Bool -> Bool -> Int -> Action ()+handleScores write killed victor total =+  unless (total == 0) $ do+    nm   <- gets (lname . slevel)+    cfg  <- gets config+    time <- gets stime+    let points  = if killed then (total + 1) `div` 2 else total+    let current = levelNumber nm   -- TODO: rather use name of level+    curDate <- liftIO getClockTime+    let score   = H.ScoreRecord+                    points (-time) curDate current killed victor+    (placeMsg, slideshow) <- liftIO $ H.register cfg write score+    messageOverlaysConfirm placeMsg slideshow+    return ()++-- | Search for secret doors+search :: Action ()+search =+  do+    Level   { lmap = lmap } <- gets slevel+    Monster { mloc = ploc } <- gets splayer+    let searchTile (Tile (Door hv (Just n)) x,t') = Just (Tile (Door hv (Just (max (n - 1) 0))) x, t')+        searchTile t                              = Just t+        slmap = foldl (\ l m -> update searchTile (shift ploc m) l) lmap moves+    modify (updateLevel (updateLMap (const slmap)))++-- | Look around at current location+lookAround :: Action a+lookAround =+  do+    state <- get+    let lvl@(Level   { lmap = lmap }) = slevel  state+    let      Monster { mloc = ploc }  = splayer state+    -- general info about current loc+    let lookMsg = lookAt True state lmap ploc+    -- check if there's something lying around at current loc+    let t = lmap `at` ploc+    if length (titems t) <= 2+      then do+             abortWith lookMsg+      else do+             displayItems lookMsg False (titems t)+             session getConfirm+             abortWith ""++-- | Display inventory+inventory :: Action a+inventory =+  do+    player <- gets splayer+    if L.null (mitems player)+      then abortWith "You are not carrying anything"+      else do+             displayItems "This is what you are carrying:" True (mitems player)+             session getConfirm+             abortWith ""++-- | Given item is now known to the player.+discover :: Item -> Action ()+discover i = modify (updateDiscoveries (S.insert (itype i)))++drinkPotion :: Action ()+drinkPotion =+  do+    state <- get+    let lvl   @(Level   { lmap = lmap }) = slevel  state+    let player@(Monster { mloc = ploc }) = splayer state+    if L.null (mitems player)+      then abortWith "You are not carrying anything."+      else do+             i <- getPotion "What to drink?" (mitems player) "inventory"+             case i of+               Just i'@(Item { itype = Potion ptype }) ->+                 do+                   -- only one potion is consumed even if several are joined in the inventory+                   let consumed = i' { icount = 1 }+                   removeFromInventory consumed+                   message (subjectVerbIObject state player "drink" consumed "")+                   -- the potion is identified after drinking+                   discover i'+                   case ptype of+                     PotionWater   -> messageAdd "Tastes like water."+                     PotionHealing -> do+                                        messageAdd "You feel better."+                                        modify (updatePlayer (\ p -> p { mhp = min (mhpmax p) (mhp p + playerHP `div` 4) }))+               Just _  -> abortWith "you cannot drink that"+               Nothing -> neverMind True++dropItem :: Action ()+dropItem =+  do+    state <- get+    let player@(Monster { mloc = ploc }) = splayer state+    if L.null (mitems player)+      then abortWith "You are not carrying anything."+      else do+             i <- getAnyItem "What to drop?" (mitems player) "inventory"+             case i of+               Just i' ->+                 do+                   removeFromInventory i'+                   message (subjectVerbIObject state player "drop" i' "")+                   dropItemsAt [i'] ploc+               Nothing -> neverMind True++dropItemsAt :: [Item] -> Loc -> Action ()+dropItemsAt is loc = modify (updateLevel (scatterItems is loc))++-- | Remove given item from the hero's inventory.+removeFromInventory :: Item -> Action ()+removeFromInventory i =+  modify (updatePlayer (\ p -> p { mitems = removeItemByLetter i (mitems p) }))++-- | Remove given item from the given location.+removeFromLoc :: Item -> Loc -> Action ()+removeFromLoc i loc =+  modify (updateLevel (\ l -> l { lmap = M.adjust (\ (t, rt) -> (update t, rt)) loc (lmap l) }))+  where+    update t = t { titems = removeItemByType i (titems t) }++-- | Let the player choose any potion. Note that this does not guarantee a potion to be chosen,+-- as the player can override the choice.+getPotion :: String ->  -- prompt+             [Item] ->  -- all objects in question+             String ->  -- how to refer to the collection of objects, e.g. "in your inventory"+             Action (Maybe Item)+getPotion prompt is isn = getItem prompt (\ i -> case itype i of Potion {} -> True; _ -> False)+                                  "Potions" is isn++actorPickupItem :: Actor -> Action ()+actorPickupItem actor =+  do+    state <- get+    per   <- currentPerception+    let lvl@(Level { lmap = lmap }) = slevel state+    let monster   = getActor state actor+    let loc       = mloc monster+    let t         = lmap `at` loc -- the map tile in question+    let perceived = loc `S.member` pvisible per+    let isPlayer  = actor == APlayer+    -- check if something is here to pick up+    case titems t of+      []     -> abortIfWith isPlayer "nothing here"+      (i:rs) -> -- pick up first item; TODO: let player select item; not for monsters+        case assignLetter (iletter i) (mletter monster) (mitems monster) of+          Just l ->+            do+              let (ni, nitems) = joinItem (i { iletter = Just l }) (mitems monster)+              -- message is dependent on who picks up and if the hero can perceive it+              if isPlayer+                then message (letterLabel (iletter ni) ++ objectItem state (icount ni) (itype ni))+                else when perceived $+                       message $ subjectCompoundVerbIObject state monster "pick" "up" i ""+              removeFromLoc i loc+              -- add item to actor's inventory:+              updateActor actor $ \ m ->+                m { mitems = nitems, mletter = maxLetter l (mletter monster) }+          Nothing -> abortIfWith isPlayer "you cannot carry any more"++-- | Replaces the version in Actor module+updateActor :: Actor ->                 -- ^ who to update+               (Monster -> Monster) ->  -- ^ the update+               Action ()+updateActor (AMonster n) f =+  do+    monsters <- gets (lmonsters . slevel)+    let (m, ms) = updateMonster f n monsters+    modify (updateLevel (updateMonsters (const ms)))+updateActor APlayer f =+  modify (updatePlayer f)++pickupItem :: Action ()+pickupItem = actorPickupItem APlayer++-- 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.++-- | Let the player choose any item from a list of items.+getAnyItem :: String ->  -- prompt+              [Item] ->  -- all objects in question+              String ->  -- how to refer to the collection of objects, e.g. "in your inventory"+              Action (Maybe Item)+getAnyItem prompt is isn = getItem prompt (const True) "Objects" is isn++-- | 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, e.g. "in your inventory"+           Action (Maybe Item)+getItem prompt p ptext is0 isn =+  let is = L.filter p is0+      choice | L.null is = "[*]"+             | otherwise = "[" ++ letterRange (concatMap (maybeToList . iletter) is) ++ " or ?*]"+      r = do+            message (prompt ++ " " ++ choice)+            display+            let h = session nextCommand >>= h'+                h' e = case e of+                         K.Char '?' -> do+                                         -- filter for supposedly suitable objects+                                         b <- displayItems (ptext ++ " " ++ isn) True is+                                         if b then session (getOptionalConfirm (const r) h')+                                              else r+                         K.Char '*' -> do+                                         -- show all objects+                                         b <- displayItems ("Objects " ++ isn) True is0+                                         if b then session (getOptionalConfirm (const r) h')+                                              else r+                         K.Char l   -> return (find (\ i -> maybe False (== l) (iletter i)) is0)+                         _          -> return Nothing+            h+  in r++displayItems :: Message -> Bool -> [Item] -> Action Bool+displayItems msg sorted is =+    do+      state <- get+      let inv = unlines $+                L.map (\ (Item { icount = c, iletter = l, itype = t }) ->+                         letterLabel l ++ objectItem state c t ++ " ")+                      ((if sorted then sortBy (cmpLetter' `on` iletter) else id) is)+      let ovl = inv ++ more+      message msg+      overlay ovl++-- | This function performs a move (or attack) by any actor, i.e., it can handle+-- both monsters and the player.+moveOrAttack :: Bool ->        -- allow attacks?+                Bool ->        -- auto-open doors on move+                Actor ->       -- who's moving?+                Dir ->+                Action ()+moveOrAttack allowAttacks autoOpen actor dir+  | dir == (0,0) =+      -- Moving with no direction is a noop. We include it currently to prevent that+      -- monsters attack themselves by accident.+      return ()+  | otherwise =+    do+      -- We start by looking at the target position.+      state <- get+      let lvl@(Level { lmap = lmap }) = slevel  state+      let player                      = splayer state+      let monster = getActor state actor+      let loc     = mloc monster     -- current location+      let s       = lmap `at` loc    -- tile at current location+      let nloc    = loc `shift` dir  -- target location+      let t       = lmap `at` nloc   -- tile at target location+      let attackedPlayer   = [ APlayer | mloc player == nloc ]+      let attackedMonsters = L.map AMonster $+                             findIndices (\ m -> mloc m == nloc) (lmonsters lvl)+      let attacked :: [Actor]+          attacked = attackedPlayer ++ attackedMonsters+      -- At the moment, we check whether there is a monster before checking accessibility+      -- i.e., we can attack a monster on a blocked location. For instance,+      -- a monster on an open door can be attacked diagonally, and a+      -- monster capable of moving through walls can be attacked from an+      -- adjacent position.+      if not (L.null attacked)+        then if not allowAttacks then abort else do+          -- perform the attack+          mapM_ (actorAttackActor actor) attacked+        else if accessible lmap loc nloc then do+          -- perform the move+          updateActor actor (\ m -> m { mloc = nloc })+          when (actor == APlayer) $ message $ lookAt False state lmap nloc+            -- TODO: seems somewhat dubious to do this here, but perhaps it's ok+        else if autoOpen then+          -- try to check if there's a door we can open+          actorOpenClose actor False True dir+        else abort -- nothing useful we can do++actorAttackActor :: Actor -> Actor -> Action ()+actorAttackActor source target =+  do+    debug "actorAttackActor"+    state <- get+    let sm = getActor state source+    let tm = getActor state target+    -- determine the weapon used for the attack+    let sword = strongestSword (mitems sm)+    -- damage the target+    let newHp  = mhp tm - 3 - sword+    let killed = newHp <= 0+    updateActor target $ \ m ->+      if killed+        then m { mhp = 0, mtime = 0 } -- grant an immediate move to die+        -- TODO: is there a good reason not to let the monster die just here?+        else m { mhp = newHp }+    -- determine how the hero perceives the event; TODO: we have to be more+    -- precise and treat cases where two monsters fight, but only one is visible+    let combatVerb = if killed && target /= APlayer then "kill" else "hit"+    let swordMsg   = if sword == 0 then "" else+                       " with a (+" ++ show sword ++ ") sword" -- TODO: generate proper message+    let combatMsg  = subjectVerbMObject state sm combatVerb tm swordMsg+    per <- currentPerception+    let perceived  = mloc sm `S.member` pvisible per+    messageAdd $+      if perceived+        then combatMsg+        else "You hear some noises."++-- | Generate a monster, possibly.+generateMonster :: Action ()+generateMonster =+  do+    lvl    <- gets slevel+    player <- gets splayer+    nlvl   <- liftIO $ rndToIO $ addMonster lvl player+    modify (updateLevel (const nlvl))++-- | Advance the move time for the given actor.+advanceTime :: Actor -> Action ()+advanceTime actor =+  do+    time <- gets stime+    updateActor actor (\ m -> m { mtime = time + mspeed m })++-- | Possibly regenerate HP for the given actor.+regenerate :: Actor -> Action ()+regenerate actor =+  do+    time <- gets stime+    -- TODO: remove hardcoded time interval, regeneration should be an attribute of the monster+    when (time `mod` 1500 == 0) $+      updateActor actor (\ m -> m { mhp = min (mhpmax m) (mhp m + 1) })+
+ src/Actor.hs view
@@ -0,0 +1,35 @@+module Actor where++import Level+import Monster+import State++data Actor = AMonster Int  -- offset in monster list+           | APlayer+  deriving (Show, Eq)++getActor :: State -> Actor -> Monster+getActor (State { slevel = lvl, splayer = p }) a =+  case a of+    AMonster n -> lmonsters lvl !! n+    APlayer    -> p++updateActor :: (Monster -> Monster) ->        -- the update+               (Monster -> State -> IO a) ->  -- continuation+               Actor ->                       -- who to update+               State -> IO a                  -- transformed continuation+updateActor f k (AMonster n) state@(State { slevel = lvl, splayer = p }) =+  let (m,ms) = updateMonster f n (lmonsters lvl)+  in  k m (updateLevel (updateMonsters (const ms)) state)+updateActor f k APlayer      state@(State { slevel = lvl, splayer = p }) =+  k p (updatePlayer f state)++updateMonster :: (Monster -> Monster) -> Int -> [Monster] ->+                 (Monster, [Monster])+updateMonster f n ms =+  case splitAt n ms of+    (pre, x : post) -> let m = f x+                           mtimeChanged = mtime x /= mtime m+                       in (m, if mtimeChanged then snd (insertMonster m (pre ++ post))+                                              else pre ++ [m] ++ post)+    xs              -> error "updateMonster"
+ src/Command.hs view
@@ -0,0 +1,32 @@+module Command where++import Action+import Actions+import Geometry+import qualified Keys as K+import Level++data Described a = Described { chelp :: String, caction :: a }+                 | Undescribed { caction :: a }++type Command    = Described (Action ())+type DirCommand = Described (Dir -> Action ())++closeCommand     = Described "close a door"      (openclose False)+openCommand      = Described "open a door"       (openclose True)+pickupCommand    = Described "pick up an object" pickupItem+dropCommand      = Described "drop an object"    dropItem+inventoryCommand = Described "display inventory" inventory+searchCommand    = Described "search for secret doors" search+ascendCommand    = Described "ascend a level"    (lvlchange Up)+descendCommand   = Described "descend a level"   (lvlchange Down)+lookCommand      = Described "look around"       lookAround+drinkCommand     = Described "quaff a potion"    drinkPotion+waitCommand      = Described "wait"              (return () :: Action ())+saveCommand      = Described "save and quit the game" saveGame+quitCommand      = Described "quit without saving" quitGame+historyCommand   = Described "display previous messages" displayHistory++moveDirCommand   = Described "move in direction" move+runDirCommand    = Described "run in direction"  run+
+ src/Config.hs view
@@ -0,0 +1,71 @@+module Config where++import System.Directory+import System.FilePath+import Control.Monad.Error++import Data.ConfigFile+import Data.Either.Utils+import Data.Maybe+import qualified Data.Binary as B++newtype CP = CP ConfigParser++instance B.Binary CP where+  put (CP config) = B.put $ to_string config+  get = do+    string <- B.get+    let parsed = readstring emptyCP string+    return $ CP $ forceEither $ parsed++instance Show CP where+  show (CP config) = show $ to_string config++-- | Underscore in the name to avoid name clash.+empty_CP :: CP+empty_CP = CP emptyCP++-- | Path to the main configuration file.+file :: IO String+file =+  do+    appData <- getAppUserDataDirectory "LambdaHack"+    return $ combine appData "LambdaHack.config"++-- | The configuration read from the main configuration file.+-- If no such file, generate empty configuration.+config :: IO CP+config =+  do+    f <- file+    b <- doesFileExist f+    if not b+      then return $ empty_CP+      else do+        c <- readfile emptyCP f+        return $ CP (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 :: Get_C a => CP -> SectionSpec -> OptionSpec ->+             Maybe a+getOption (CP config) s o =+  do+    if has_option config s o+      then let val = get config s o+               valForced = forceEither val+           in  Just valForced+      else Nothing++-- | Looks up a file path in the config file, faling back to the default path.+-- The path from the config file is taken relative to the home directory+-- and the default is taken relative to the current directory. In any case,+-- the returned path is absolute.+getFile :: CP -> FilePath -> SectionSpec -> OptionSpec -> IO FilePath+getFile config dflt s o =+  do+    current <- getCurrentDirectory+    appData <- getAppUserDataDirectory "LambdaHack"+    let path = getOption config s o+    return $ maybe (combine current dflt) (combine appData) path
+ src/Display.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE CPP #-}++module Display (module D) where++-- wrapper for selected Display frontend++#ifdef CURSES+import Display.Curses as D+#elif GTK+import Display.Gtk as D+#else+import Display.Vty as D+#endif+
+ src/Display/Curses.hs view
@@ -0,0 +1,125 @@+module Display.Curses+  (displayId, startup, shutdown,+   display, nextEvent, setBG, setFG, setBold, Session,+   white, black, yellow, blue, magenta, red, green, attr, Display.Curses.Attr) where++import UI.HSCurses.Curses as C hiding (setBold)+import qualified UI.HSCurses.CursesHelper as C+import Data.List as L+import Data.Map as M+import Data.Char+import qualified Data.ByteString as BS++import Geometry+import Keys as K++displayId = "curses"++data Session =+  Session+    { win :: Window,+      styles :: Map (Maybe AttrColor, Maybe AttrColor) C.CursesStyle }++startup :: (Session -> IO ()) -> IO ()+startup k =+  do+    C.start+    C.startColor+    cursSet CursorInvisible+    nr <- colorPairs+    let s = [ ((f,b), C.Style (toFColor f) (toBColor b))+            | f <- Nothing : L.map Just [minBound..maxBound],+              b <- Nothing : L.map Just [minBound..maxBound] ]+    let (ks, vs) = unzip (tail s)  -- drop the Nothing/Nothing combo+    ws <- C.convertStyles (take (nr - 1) vs)+    k (Session C.stdScr (M.fromList (zip ks ws)))++shutdown :: Session -> IO ()+shutdown w = C.end++display :: Area -> Session -> (Loc -> (Display.Curses.Attr, Char)) -> String -> String -> IO ()+display ((y0,x0),(y1,x1)) (Session { win = w, styles = s }) f msg status =+  do+    erase+    mvWAddStr w 0 0 msg+    sequence_ [ let (a,c) = f (y,x) in C.setStyle (findWithDefault C.defaultCursesStyle a s) >> mvWAddStr w (y+1) x [c]+              | x <- [x0..x1], y <- [y0..y1] ]+    mvWAddStr w (y1+2) 0 status+    refresh+{-+    in  V.update vty (Pic NoCursor +         ((renderBS attr (BS.pack (L.map (fromIntegral . ord) (toWidth (x1-x0+1) msg)))) <->+          img <-> +          (renderBS attr (BS.pack (L.map (fromIntegral . ord) (toWidth (x1-x0+1) status))))))+-}++{-+toWidth :: Int -> String -> String+toWidth n x = take n (x ++ repeat ' ')+-}++keyTranslate :: C.Key -> Maybe K.Key+keyTranslate e =+  case e of+    C.KeyChar '\ESC' -> Just K.Esc+    C.KeyExit        -> Just K.Esc+    C.KeyChar '\n'   -> Just K.Return+    C.KeyChar '\r'   -> Just K.Return+    C.KeyEnter       -> Just K.Return+    C.KeyUp          -> Just K.Up+    C.KeyDown        -> Just K.Down+    C.KeyLeft        -> Just K.Left+    C.KeyRight       -> Just K.Right+    C.KeyHome        -> Just K.Home+    C.KeyPPage       -> Just K.PgUp+    C.KeyEnd         -> Just K.End+    C.KeyNPage       -> Just K.PgDn+    C.KeyBeg         -> Just K.Begin+    C.KeyB2          -> Just K.Begin+    C.KeyChar c      -> Just (K.Char c)+    _                -> Nothing++nextEvent :: Session -> IO K.Key+nextEvent session =+  do+    e <- C.getKey refresh+    maybe (nextEvent session) return (keyTranslate e)++type Attr = (Maybe AttrColor, Maybe AttrColor)++attr = (Nothing, Nothing)++data AttrColor = White | Black | Yellow | Blue | Magenta | Red | Green +  deriving (Show, Eq, Ord, Enum, Bounded)++toFColor :: Maybe AttrColor -> C.ForegroundColor+toFColor (Just White)    = C.WhiteF+toFColor (Just Black)    = C.BlackF+toFColor (Just Yellow)   = C.BrownF+toFColor (Just Blue)     = C.DarkBlueF+toFColor (Just Magenta)  = C.PurpleF+toFColor (Just Red)      = C.DarkRedF+toFColor (Just Green)    = C.DarkGreenF+toFColor Nothing         = C.DefaultF++toBColor :: Maybe AttrColor -> C.BackgroundColor+toBColor (Just White)    = C.WhiteB+toBColor (Just Black)    = C.BlackB+toBColor (Just Yellow)   = C.BrownB+toBColor (Just Blue)     = C.DarkBlueB+toBColor (Just Magenta)  = C.PurpleB+toBColor (Just Red)      = C.DarkRedB+toBColor (Just Green)    = C.DarkGreenB+toBColor Nothing         = C.DefaultB++white   = White+black   = Black+yellow  = Yellow+blue    = Blue+magenta = Magenta+red     = Red+green   = Green++setBold (f, b) = (f, b)+setFG c (_, b) = (Just c, b)+setBG c (f, _) = (f, Just c)
+ src/Display/Gtk.hs view
@@ -0,0 +1,214 @@+module Display.Gtk+  (displayId, startup, shutdown, +   display, nextEvent, setBG, setFG, setBold, Session,+   white, black, yellow, blue, magenta, red, green, attr, Attr) where++import Control.Monad+import Control.Concurrent+import Graphics.UI.Gtk.Gdk.Events  -- TODO: replace, deprecated+import Graphics.UI.Gtk hiding (Attr)+import Data.List as L+import Data.IORef+import Data.Map as M++import Geometry+import Keys as K++displayId = "gtk"++data Session =+  Session {+    schan :: Chan String,+    stags :: Map AttrKey TextTag,+    sview :: TextView }++doAttr :: TextTag -> AttrKey -> IO ()+doAttr tt (BG Blue)    = set tt [ textTagBackground := "#0000CC" ]+doAttr tt (BG Magenta) = set tt [ textTagBackground := "#CC00CC" ]+doAttr tt (BG Green)   = set tt [ textTagBackground := "#00CC00" ]+doAttr tt (BG Red)     = set tt [ textTagBackground := "#CC0000" ]+doAttr tt (BG White)   = set tt [ textTagBackground := "#FFFFFF" ]+doAttr tt (FG Green)   = set tt [ textTagForeground := "#00FF00" ]+doAttr tt (FG Red)     = set tt [ textTagForeground := "#FF0000" ]+doAttr tt (FG Blue)    = set tt [ textTagForeground := "#0000FF" ]+doAttr tt (FG Yellow)  = set tt [ textTagForeground := "#CCCC00" ]+doAttr tt (FG Black)   = set tt [ textTagForeground := "#000000" ]+doAttr tt _            = return ()++startup :: (Session -> IO ()) -> IO ()+startup k =+  do+    -- initGUI+    unsafeInitGUIForThreadedRTS+    w <- windowNew++    ttt <- textTagTableNew+    -- text attributes+    tts <- fmap M.fromList $+           mapM (\ c -> do+                          tt <- textTagNew Nothing+                          textTagTableAdd ttt tt+                          doAttr tt c+                          return (c,tt))+                [ x | c <- [minBound .. maxBound], x <- [FG c, BG c]]++    -- 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+                                   fd <- fontDescriptionToString cf+                                   fontSelectionDialogSetFontName fsd fd+                                   fontSelectionDialogSetPreviewText fsd "+##@##-...|"+                                   response <- dialogRun fsd+                                   when (response == 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+    let white = Color maxBound maxBound maxBound+    widgetModifyBase tv StateNormal black+    widgetModifyText tv StateNormal white++    ec <- newChan +    forkIO $ k (Session ec tts tv)+    +    onKeyPress tv (\ e -> postGUIAsync (writeChan ec (Graphics.UI.Gtk.Gdk.Events.eventKeyName e)) >> return True)++    onDestroy w mainQuit -- set quit handler+    widgetShowAll w+    yield+    mainGUI++shutdown _ = mainQuit++display :: Area -> Session -> (Loc -> (Attr, Char)) -> String -> String -> IO ()+display ((y0,x0),(y1,x1)) session f msg status =+  postGUIAsync $+  do+    tb <- textViewGetBuffer (sview session)+    let text = unlines [ [ snd (f (y,x)) | x <- [x0..x1] ] | y <- [y0..y1] ]+    textBufferSetText tb (msg ++ "\n" ++ text ++ status)+    sequence_ [ setTo tb (stags session) (y,x) a | +                y <- [y0..y1], x <- [x0..x1], let loc = (y,x), let (a,c) = f (y,x) ]++setTo :: TextBuffer -> Map AttrKey TextTag -> Loc -> Attr -> IO ()+setTo tb tts (ly,lx) a =+  do+    ib <- textBufferGetIterAtLineOffset tb (ly+1) lx+    ie <- textIterCopy ib+    textIterForwardChar ie+    mapM_ (\ c -> textBufferApplyTag tb (tts ! c) ib ie) a++-- | 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++keyTranslate :: String -> Maybe K.Key+keyTranslate "less"          = Just (K.Char '<')+keyTranslate "greater"       = Just (K.Char '>')+keyTranslate "period"        = Just (K.Char '.')+keyTranslate "colon"         = Just (K.Char ':')+keyTranslate "comma"         = Just (K.Char ',')+keyTranslate "space"         = Just (K.Char ' ')+keyTranslate "question"      = Just (K.Char '?')+keyTranslate "asterisk"      = Just (K.Char '*')+keyTranslate "Escape"        = Just K.Esc+keyTranslate "Return"        = Just K.Return+keyTranslate "KP_Up"         = Just K.Up+keyTranslate "KP_Down"       = Just K.Down+keyTranslate "KP_Left"       = Just K.Left+keyTranslate "KP_Right"      = Just K.Right+keyTranslate "KP_Home"       = Just K.Home+keyTranslate "KP_End"        = Just K.End+keyTranslate "KP_Page_Up"    = Just K.PgUp+keyTranslate "KP_Page_Down"  = Just K.PgDn+keyTranslate "KP_Begin"      = Just K.Begin+keyTranslate "KP_Enter"      = Just K.Return+keyTranslate ['K','P','_',c] = Just (K.Char c)  -- for numbers+keyTranslate [c]             = Just (K.Char c)+keyTranslate _               = Nothing++nextEvent :: Session -> IO K.Key+nextEvent session =+  do+    e <- readUndeadChan (schan session)+    maybe (nextEvent session) return (keyTranslate e)++setBold   = id  -- not supported yet+setBG c   = (BG c :)+setFG c   = (FG c :)+blue      = Blue+magenta   = Magenta+red       = Red+yellow    = Yellow+green     = Green+white     = White+black     = Black+attr      = []++type Attr = [AttrKey]++data AttrKey =+    FG AttrColor+  | BG AttrColor+  deriving (Eq, Ord)++type Color = AttrColor++data AttrColor =+    Blue+  | Magenta+  | Red+  | Green+  | Yellow+  | White+  | Black+  deriving (Eq, Ord, Enum, Bounded)
+ src/Display/Vty.hs view
@@ -0,0 +1,64 @@+module Display.Vty+  (displayId, startup, shutdown,+   display, nextEvent, setBold, setBG, setFG, Session,+   white, black, yellow, blue, magenta, red, green, attr, Attr) where++import Graphics.Vty as V+import Data.List as L+import Data.Char+import qualified Data.ByteString as BS++import Geometry+import Keys as K++displayId = "vty"++type Session = V.Vty++startup :: (Session -> IO ()) -> IO ()+startup k = V.mkVty >>= k++display :: Area -> Session -> (Loc -> (Attr, Char)) -> String -> String -> IO ()+display ((y0,x0),(y1,x1)) vty f msg status =+    let img = (foldr (<->) V.empty_image .+               L.map (foldr (<|>) V.empty_image .+                      L.map (\ (x,y) -> let (a,c) = f (y,x) in char a c)))+              [ [ (x,y) | x <- [x0..x1] ] | y <- [y0..y1] ]+    in  V.update vty (pic_for_image+         (utf8_bytestring attr (BS.pack (L.map (fromIntegral . ord) (toWidth (x1 - x0 + 1) msg))) <->+          img <-> +          utf8_bytestring attr (BS.pack (L.map (fromIntegral . ord) (toWidth (x1 - x0 + 1) status)))))++toWidth :: Int -> String -> String+toWidth n x = take n (x ++ repeat ' ')++keyTranslate :: V.Event -> Maybe K.Key+keyTranslate e =+  case e of+    V.EvKey KEsc []         -> Just K.Esc+    V.EvKey KEnter []       -> Just K.Return+    V.EvKey KUp []          -> Just K.Up+    V.EvKey KDown []        -> Just K.Down+    V.EvKey KLeft []        -> Just K.Left+    V.EvKey KRight []       -> Just K.Right+    V.EvKey KHome []        -> Just K.Home+    V.EvKey KPageUp []      -> Just K.PgUp+    V.EvKey KEnd []         -> Just K.End+    V.EvKey KPageDown []    -> Just K.PgDn+    V.EvKey KBegin []       -> Just K.Begin+    V.EvKey (KASCII c) []   -> Just (K.Char c)+    _                       -> Nothing++nextEvent :: Session -> IO K.Key+nextEvent session =+  do+    e <- V.next_event session+    maybe (nextEvent session) return (keyTranslate e)++attr = def_attr++setBold a = with_style a bold++setBG c a = with_back_color a c++setFG c a = with_fore_color a c
+ src/Display2.hs view
@@ -0,0 +1,194 @@+module Display2 (module Display, module Display2) where++-- Display routines that are independent of the selected display frontend.++import Data.Set as S+import Data.List as L+import Data.Map as M+import Control.Monad.State hiding (State) -- for MonadIO, seems to be portable between mtl-1 and 2++import Message+import Display+import State+import Geometry+import Level+import LevelState+import Dungeon+import Perception+import Monster+import Item+import Keys as K++-- | Next event translated to a canonical form+nextCommand :: MonadIO m => Session -> m Key+nextCommand session =+  do+    e <- liftIO $ nextEvent session+    return (canonicalKey e)++-- | maps a key to the canonical key for the command it denotes+canonicalKey :: Key -> Key+canonicalKey e =+  case e of+    K.Char '8' -> K.Char 'K'+    K.Char '2' -> K.Char 'J'+    K.Char '4' -> K.Char 'H'+    K.Char '6' -> K.Char 'L'+    K.Char '7' -> K.Char 'Y'+    K.Char '9' -> K.Char 'U'+    K.Char '1' -> K.Char 'B'+    K.Char '3' -> K.Char 'N'+    K.Char '5' -> K.Char '.'+    K.Up       -> K.Char 'k'+    K.Down     -> K.Char 'j'+    K.Left     -> K.Char 'h'+    K.Right    -> K.Char 'l'+    K.Home     -> K.Char 'y'+    K.PgUp     -> K.Char 'u'+    K.End      -> K.Char 'b'+    K.PgDn     -> K.Char 'n'+    K.Begin    -> K.Char '.'+    k          -> k++-- | Displays a message on a blank screen. Waits for confirmation.+displayBlankConfirm :: Session -> String -> IO Bool+displayBlankConfirm session txt =+  let x = txt ++ more+  in  do+        display ((0, 0), normalLevelSize) session (const (attr, ' ')) x ""+        getConfirm session++-- | Waits for a space or return.+getConfirm :: MonadIO m => Session -> m Bool+getConfirm session =+  getOptionalConfirm return (const $ getConfirm session) session++getOptionalConfirm :: MonadIO m => (Bool -> m a) -> (Key -> m a) -> Session -> m a+getOptionalConfirm h k session =+  do+    e <- liftIO $ nextCommand session+    case e of+      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++-- | Configurable event handler for the direction keys. Is used to+--   handle player moves, but can also be used for directed commands+--   such as open/close.+handleDirection :: Key -> (Dir -> a) -> a -> a+handleDirection e h k =+  case e of+    K.Char 'k' -> h up+    K.Char 'j' -> h down+    K.Char 'h' -> h left+    K.Char 'l' -> h right+    K.Char 'y' -> h upleft+    K.Char 'u' -> h upright+    K.Char 'b' -> h downleft+    K.Char 'n' -> h downright+    _          -> k++-- | Configurable event handler for the upper direction keys. Is used to+--   handle player moves, but can also be used for directed commands+--   such as open/close.+handleUDirection :: Key -> (Dir -> a) -> a -> a+handleUDirection e h k =+  case e of+    K.Char 'K' -> h up+    K.Char 'J' -> h down+    K.Char 'H' -> h left+    K.Char 'L' -> h right+    K.Char 'Y' -> h upleft+    K.Char 'U' -> h upright+    K.Char 'B' -> h downleft+    K.Char 'N' -> h downright+    _          -> k++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, Loc -> 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, \ (y,x) -> M.lookup y m >>= \ n -> M.lookup x n)++displayLevel :: Session -> Perception -> State -> Message -> Maybe String -> IO Bool+displayLevel session per+             (state@(State { splayer = player@(Monster { mhpmax = phpmax, mhp = php, mdir = pdir, mloc = ploc }),+                             stime   = time,+                             sassocs = assocs,+                             slevel  = lvl@(Level nm sz@(sy,sx) ms smap nlmap lmeta) }))+             msg moverlay =+    let+      overlay = maybe "" id moverlay+      reachable = preachable per+      visible   = pvisible per+      sSml    = ssensory state == Smell+      sVis    = case ssensory state of Vision _ -> True; _ -> False+      sOmn    = sdisplay state == Omniscient+      sTer    = case sdisplay state of Terrain n -> n; _ -> 0+      lAt     = if sOmn || sTer > 0 then at else rememberAt+      lVision = if sVis+                  then \ vis rea ->+                       if      vis then setBG blue+                       else if rea then setBG magenta+                                   else id+                  else \ vis rea -> id+      (n,over) = stringByLocation (sy+1) overlay -- n is the number of overlay screens+      gold    = maybe 0 (icount . fst) $ findItem (\ i -> iletter i == Just '$') (mitems player)+      disp n msg =+        display ((0,0),sz) session+                 (\ loc -> let tile = nlmap `lAt` loc+                               sml  = ((smap ! loc) - time) `div` 100+                               vis  = S.member loc visible+                               rea  = S.member loc reachable+                               (rv,ra) = case L.find (\ m -> loc == mloc m) (player:ms) of+                                           _ | sTer > 0          -> viewTerrain sTer False (tterrain tile)+                                           Just m | sOmn || vis  -> viewMonster (mtype m)+                                           _ | sSml && sml >= 0  -> viewSmell sml+                                             | otherwise         -> viewTile vis tile assocs+                               vision = lVision vis rea+                           in+                             case over (loc `shift` ((sy+1) * n, 0)) of+                               Just c  ->  (attr, c)+                               _       ->  (ra . vision $ attr, rv))+                msg+                (take 40 (levelName nm ++ repeat ' ') +++                 take 10 ("$: " ++ show gold ++ repeat ' ') +++                 take 15 ("HP: " ++ show php ++ " (" ++ show phpmax ++ ")" ++ repeat ' ') +++                 take 10 ("T: " ++ show (time `div` 10) ++ repeat ' '))+      msgs = splitMsg sx msg+      perf k []     = perfo k ""+      perf k [xs]   = perfo k xs+      perf k (x:xs) = disp n (x ++ more) >> getConfirm session >>= \ b ->+                      if b then perf k xs else return False+      perfo k xs+        | k < n - 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
+ src/Dungeon.hs view
@@ -0,0 +1,324 @@+module Dungeon where++import Prelude hiding (floor)+import Control.Monad++import Data.Map as M+import Data.List as L+import Data.Ratio++import State+import Geometry+import Level+import Monster+import Item+import Random++type Corridor = [(Y,X)]+type Room = Area++-- | Create a random room according to given parameters.+mkRoom :: Int ->      -- ^ border columns+          (Y,X) ->    -- ^ 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 (ym,xm) ((y0,x0),(y1,x1)) =+  do+    (ry0,rx0) <- locInArea ((y0 + bd,x0 + bd),(y1 - bd - ym + 1,x1 - bd - xm + 1))+    (ry1,rx1) <- locInArea ((ry0 + ym - 1,rx0 + xm - 1),(y1 - bd,x1 - bd))+    return ((ry0,rx0),(ry1,rx1))++-- | Create a no-room, i.e., a single corridor field.+mkNoRoom :: Int ->      -- ^ border columns+            Area ->     -- ^ this is an area, not the room itself+            Rnd Room    -- ^ this is the upper-left and lower-right corner of the room+mkNoRoom bd ((y0,x0),(y1,x1)) =+  do+    (ry,rx) <- locInArea ((y0 + bd,x0 + bd),(y1 - bd,x1 - bd))+    return ((ry,rx),(ry,rx))++-- | Create a corridor, either horizontal or vertical, with+-- a possible intermediate part that is in the opposite direction.+mkCorridor :: HV -> (Loc,Loc) -> Area -> Rnd [(Y,X)] {- straight sections of the corridor -}+mkCorridor hv ((y0,x0),(y1,x1)) b =+  do+    (ry,rx) <- findLocInArea b (const True)+    -- (ry,rx) is intermediate point the path crosses+    -- hv decides whether we start in horizontal or vertical direction+    case hv of+      Horiz -> return [(y0,x0),(y0,rx),(y1,rx),(y1,x1)]+      Vert  -> return [(y0,x0),(ry,x0),(ry,x1),(y1,x1)]++-- | 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 [Loc]+connectRooms sa@((sy0,sx0),(sy1,sx1)) ta@((ty0,tx0),(ty1,tx1)) =+  do+    (sy,sx) <- locInArea sa+    (ty,tx) <- locInArea ta+    let xok = sx1 < tx0 - 3+    let xarea = normalizeArea ((sy,sx1+2),(ty,tx0-2))+    let yok = sy1 < ty0 - 3+    let yarea = normalizeArea ((sy1+2,sx),(ty0-2,tx))+    let xyarea = normalizeArea ((sy1+2,sx1+2),(ty0-2,tx0-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 ((sy,sx),(ty,tx)) area++-- | Actually dig a corridor.+digCorridor :: Corridor -> LMap -> LMap+digCorridor (p1:p2:ps) l =+  digCorridor (p2:ps) (M.unionWith corridorUpdate newPos l)+  where+    newPos = M.fromList [ (ps,newTile Corridor) | ps <- fromTo p1 p2 ]+    corridorUpdate _ (Tile (Wall hv) is,u)    = (Tile (Opening hv) is,u)+    corridorUpdate _ (Tile (Opening hv) is,u) = (Tile (Opening hv) is,u)+    corridorUpdate _ (Tile (Floor l) is,u)    = (Tile (Floor l) is,u)+    corridorUpdate (x,u) _                    = (x,u)+digCorridor _ l = l++-- | Create a new tile.+newTile :: Terrain -> (Tile, Tile)+newTile t = (Tile t [], Tile Unknown [])++-- | Create a level consisting of only one room. Optionally, insert some walls.+emptyroom :: (Level -> Rnd (LMap -> LMap)) -> LevelConfig ->+           LevelName -> Rnd (Maybe (Maybe DungeonLoc) -> Maybe (Maybe DungeonLoc) -> Level, Loc, Loc)+emptyroom addWallsRnd cfg@(LevelConfig { levelSize = (sy,sx) }) nm =+  do+    let lmap = digRoom Light ((1,1),(sy-1,sx-1)) (emptyLMap (sy,sx))+    let smap = M.fromList [ ((y,x),-100) | y <- [0..sy], x <- [0..sx] ]+    let lvl = Level nm (sy,sx) [] smap lmap ""+    -- locations of the stairs+    su <- findLoc lvl (const floor)+    sd <- findLoc lvl (\ l t -> floor t+                                && distance (su,l) > minStairsDistance cfg)+    is <- rollItems cfg lvl su+    addWalls <- addWallsRnd lvl+    let addItem lmap (l,it) =+          M.update (\ (t,r) -> Just (t { titems = it : titems t }, r)) l lmap+        flmap lu ld =+          addWalls $+          maybe id (\ l -> M.insert su (newTile (Stairs Light Up   l))) lu $+          maybe id (\ l -> M.insert sd (newTile (Stairs Light Down l))) ld $+          (\lmap -> foldl' addItem lmap is) $+          lmap+        level lu ld = Level nm (sy,sx) [] smap (flmap lu ld) "bigroom"+    return (level, su, sd)++-- | For a bigroom level: Create a level consisting of only one, empty room.+bigroom :: LevelConfig ->+           LevelName -> Rnd (Maybe (Maybe DungeonLoc) -> Maybe (Maybe DungeonLoc) -> Level, Loc, Loc)+bigroom = emptyroom (\ lvl -> return id)++-- | For a noiseroom level: Create a level consisting of only one room+-- with randomly distributed pillars.+noiseroom :: LevelConfig ->+             LevelName -> Rnd (Maybe (Maybe DungeonLoc) -> Maybe (Maybe DungeonLoc) -> Level, Loc, Loc)+noiseroom cfg =+  let addWalls lvl = do+        rs <- rollPillars cfg lvl+        let insertWall lmap l =+              case lmap `at` l of+                Tile (Floor _) [] -> M.insert l (newTile (Wall O)) lmap+                _ -> lmap+        return $ \ lmap -> foldl' insertWall lmap rs+  in  emptyroom addWalls cfg++data LevelConfig =+  LevelConfig {+    levelGrid         :: Rnd (Y,X),+    minRoomSize       :: Rnd (Y,X),+    darkRoomChance    :: Rnd Bool,+    border            :: Int,       -- must be at least 2!+    levelSize         :: (Y,X),     -- lower right point+    extraConnects     :: (Y,X) -> Int,+                                    -- relative to grid+                                    -- (in fact a range, because of duplicate connects)+    noRooms           :: (Y,X) -> Rnd Int,+                                    -- range, relative to grid+    minStairsDistance :: Int,       -- must not be too large+    doorChance        :: Rnd Bool,+    doorOpenChance    :: Rnd Bool,+    doorSecretChance  :: Rnd Bool,+    doorSecretMax     :: Int,+    nrItems           :: Rnd Int,   -- range+    depth             :: Int        -- general indicator of difficulty+  }++normalLevelSize :: (Y,X)+normalLevelSize = (22,79)++defaultLevelConfig :: Int -> LevelConfig+defaultLevelConfig d =+  LevelConfig {+    levelGrid         = do+                          y <- randomR (2,4)+                          x <- randomR (3,5)+                          return (y,x),+    minRoomSize       = return (2,2),+    darkRoomChance    = chance $ 1%((22 - (2 * fromIntegral d)) `max` 2),+    border            = 2,+    levelSize         = normalLevelSize,+    extraConnects     = \ (y,x) -> (y*x) `div` 3,+    noRooms           = \ (y,x) -> randomR (0,(y*x) `div` 3),+    minStairsDistance = 676,+    doorChance        = chance $ 2%3,+    doorOpenChance    = chance $ 1%10,+    doorSecretChance  = chance $ 1%4,+    doorSecretMax     = 15,+    nrItems           = randomR (5,10),+    depth             = d+  }++largeLevelConfig :: Int -> LevelConfig+largeLevelConfig d =+  (defaultLevelConfig d) {+    levelGrid         = return (7,10),+    levelSize         = (77,231),+    extraConnects     = const 10+  }++-- | Create a "normal" dungeon level. Takes a configuration in order+-- to tweak all sorts of data.+level :: LevelConfig ->+         LevelName ->+         Rnd (Maybe (Maybe DungeonLoc) -> Maybe (Maybe DungeonLoc) ->+              Level, Loc, Loc)+level cfg nm =+  do+    lgrid    <- levelGrid cfg+    lminroom <- minRoomSize cfg+    let gs = M.toList (grid lgrid ((0,0),levelSize cfg))+    -- grid locations of "no-rooms"+    nrnr <- noRooms cfg lgrid+    nr   <- replicateM nrnr (do+                               let (y,x) = lgrid+                               yg <- randomR (0,y-1)+                               xg <- randomR (0,x-1)+                               return (yg,xg))+    rs0 <- mapM (\ (i,r) -> do+                              r' <- if i `elem` nr+                                      then mkNoRoom (border cfg) r+                                      else mkRoom (border cfg) lminroom r+                              return (i,r')) gs+    let rooms :: [(Loc, Loc)]+        rooms = L.map snd rs0+    dlrooms <- (mapM (\ r -> darkRoomChance cfg >>= \ c -> return (r, toDL (not c))) rooms) :: Rnd [((Loc, Loc), DL)]+    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 ! p0+                               r1 = rs ! p1+                           connectRooms r0 r1) allConnects+    let smap = M.fromList [ ((y,x),-100) | let (sy,sx) = levelSize cfg,+                                           y <- [0..sy], x <- [0..sx] ]+    let lmap :: LMap+        lmap = foldr digCorridor (foldr (\ (r, dl) m -> digRoom dl r m)+                                        (emptyLMap (levelSize cfg)) dlrooms) cs+    let lvl = Level nm (levelSize cfg) [] smap lmap ""+    -- convert openings into doors+    dlmap <- fmap M.fromList . mapM+                (\ o@((y,x),(t,r)) ->+                  case t of+                    Tile (Opening hv) _ ->+                      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+                        rs <- if ro then return Nothing+                                    else do rsc <- doorSecretChance cfg+                                            fmap Just+                                                 (if rsc then randomR (1, doorSecretMax cfg)+                                                         else return 0)+                        if rb+                          then return ((y,x),newTile (Door hv rs))+                          else return o+                    _ -> return o) .+                M.toList $ lmap+    -- locations of the stairs+    su <- findLoc lvl (const floor)+    sd <- findLocTry 1000 lvl+            (const floor)+            (\ l t -> distance (su,l) > minStairsDistance cfg)+    -- determine number of items, items and locations for the items+    is <- rollItems cfg lvl su+    -- generate map and level from the data+    let meta = show allConnects+    return (\ lu ld ->+      let flmap = maybe id (\ l -> M.update (\ (t,r) -> Just $ newTile (Stairs (toDL $ light t) Up   l)) su) lu $+                  maybe id (\ l -> M.update (\ (t,r) -> Just $ newTile (Stairs (toDL $ light t) Down l)) sd) ld $+                  foldr (\ (l,it) f -> M.update (\ (t,r) -> Just (t { titems = it : titems t }, r)) l . f) id is+                  dlmap+      in  Level nm (levelSize cfg) [] smap flmap meta, su, sd)++rollItems :: LevelConfig -> Level -> Loc -> Rnd [(Loc, Item)]+rollItems cfg lvl ploc =+  do+    nri <- nrItems cfg+    replicateM nri $+      do+        t <- newItem (depth cfg) itemFrequency+        l <- case itype t of+               Sword _ ->+                 -- swords generated close to monsters; MUAHAHAHA+                 findLocTry 200 lvl+                   (const floor)+                   (\ l t -> distance (ploc, l) > 400)+               _ -> findLoc lvl (const floor)+        return (l,t)++rollPillars :: LevelConfig -> Level -> Rnd [Loc]+rollPillars cfg lvl =+  do+    nri <- 100 *~ nrItems cfg+    replicateM nri $+      do+        l <- findLoc lvl (const floor)+        return l++emptyLMap :: (Y,X) -> LMap+emptyLMap (my,mx) = M.fromList [ ((y,x),newTile Rock) | x <- [0..mx], y <- [0..my] ]++-- | If the room has size 1, it is assumed to be a no-room, and a single+-- corridor field will be dug instead of a room.+digRoom :: DL -> Room -> LMap -> LMap+digRoom dl ((y0,x0),(y1,x1)) l+  | y0 == y1 && x0 == x1 =+  M.insert (y0,x0) (newTile Corridor) l+  | otherwise =+  let rm = M.fromList $ [ ((y,x),newTile (Floor dl))   | x <- [x0..x1],     y <- [y0..y1]    ]+                     ++ [ ((y,x),newTile (Wall p))     | (x,y,p) <- [(x0-1,y0-1,UL),(x1+1,y0-1,UR),(x0-1,y1+1,DL),(x1+1,y1+1,DR)] ]+                     ++ [ ((y,x),newTile (Wall p))     | x <- [x0..x1], (y,p) <- [(y0-1,U),(y1+1,D)] ]+                     ++ [ ((y,x),newTile (Wall p))     | (x,p) <- [(x0-1,L),(x1+1,R)],  y <- [y0..y1]    ]+  in M.unionWith const rm l++-- | Create a new monster in the level, at a random position.+addMonster :: Level -> Player -> Rnd Level+addMonster lvl@(Level { lmonsters = ms, lmap = lmap })+           player@(Monster { mloc = ploc }) =+  do+    rc <- monsterGenChance (lname lvl) ms+    if rc+     then 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+            sm <- findLocTry 1000 lvl+                    (\ l t -> not (l `L.elem` L.map mloc (player : ms))+                              && open t)+                    (\ l t -> distance (ploc, l) > 400+                              && floor t)+            m <- newMonster sm monsterFrequency+            return (updateMonsters (const (m : ms)) lvl)+     else return lvl
+ src/FOV.hs view
@@ -0,0 +1,414 @@+module FOV where++import Data.Map as M+import Data.Set as S+import Data.List as L+import Data.Ratio+import Data.Maybe+import Debug.Trace++import Geometry+import Level++type Interval = (Rational, Rational)+type Distance = Int+type Progress = Int+newtype Bump      = B Loc  deriving (Show)+type Line         = (Bump, Bump)+type ConvexHull   = [Bump]+type Edge         = (Line, ConvexHull)+type EdgeInterval = (Edge, Edge)++data FovMode = Shadow | Permissive Int | Diagonal Int++-- Three Field of View algorithms. Press 'V' to cycle among them in the game.++-- The main FOV function.++-- | Perform a full scan for a given location. Returns the locations+-- that are currently in the field of view.+fullscan :: FovMode -> Loc -> LMap -> Set Loc+fullscan fovMode loc lmap =+  case fovMode of+    Shadow ->         -- shadow casting with infinite range+      S.unions $+      L.map (\ tr ->+              scan (tr loc) lmap 1 (0,1)) -- was: scan (tr loc) lmap 0 (0,1); TODO: figure out what difference this makes+      [tr0,tr1,tr2,tr3,tr4,tr5,tr6,tr7]+    Permissive r  ->  -- permissive with range r+      S.unions $+      L.map (\ tr ->+              pscan r (tr loc) lmap 1+                (((B(1, 0), B(0, r+1)), [B(0, 1)]),+                 ((B(0, 1), B(r+1, 0)), [B(1, 0)])))+      [qtr0,qtr1,qtr2,qtr3]+    Diagonal r    ->  -- diagonal with range r+      S.unions $+      L.map (\ tr ->+              dscan r (tr loc) lmap 1+                (((B(0, 1), B(r, -r)),  [B(0, 0)]),+                 ((B(0, 0), B(r, r+1)), [B(0, 1)])))+      [qtr0,qtr1,qtr2,qtr3]++-- Common functions.++-- | The translation, rotation and symmetry functions for octants.+tr0 (oy,ox) (d,p) = (oy + d,ox + p)+tr1 (oy,ox) (d,p) = (oy + d,ox - p)+tr2 (oy,ox) (d,p) = (oy - d,ox + p)+tr3 (oy,ox) (d,p) = (oy - d,ox - p)+tr4 (oy,ox) (d,p) = (oy + p,ox + d)+tr5 (oy,ox) (d,p) = (oy + p,ox - d)+tr6 (oy,ox) (d,p) = (oy - p,ox + d)+tr7 (oy,ox) (d,p) = (oy - p,ox - d)++-- | The translation and rotation functions for quadrants.+qtr0, qtr1, qtr2, qtr3 :: Loc -> Bump -> Loc+qtr0 (oy, ox) (B(y, x)) = (oy - y, ox + x)  -- first quadrant+qtr1 (oy, ox) (B(y, x)) = (oy - x, ox - y)  -- then rotated clockwise 90 degrees+qtr2 (oy, ox) (B(y, x)) = (oy + y, ox - x)+qtr3 (oy, ox) (B(y, x)) = (oy + x, ox + y)++-- | Integer division, rounding up.+divUp n k = - (-n) `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 x -> if gte x acc then x 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(yf, xf)) (B(y1, x1)) (B(y2, x2)) =+  (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 b l =+  case l of+    x:y:zs ->+      if gte x y+      then addHull gte b (y:zs)+      else b : l+    _ -> b : l++-- 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 LambdaHack only+-- when two corridors touch diagonally by accident and on the random pillars+-- levels.++-- | 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 :: ((Distance, Progress) -> Loc) -> LMap -> Distance -> Interval -> Set Loc+scan tr l d (s,e) =+    let ps = downBias (s * fromIntegral d)   -- minimal progress to check+        pe = upBias (e * fromIntegral d)     -- maximal progress to check+        st = if open (l `at` tr (d,ps)) then Just s   -- start in light+                                        else Nothing  -- start in shadow+    in+        -- trace (show (d,s,e,ps,pe)) $+        S.union (S.fromList [tr (d,p) | p <- [ps..pe]]) (scan' st ps pe)+  where+    scan' :: Maybe Rational -> Progress -> Progress -> Set Loc+    -- scan' st ps pe+    --   | trace (show (st,ps,pe)) False = undefined+    scan' (Just s) ps pe+      | s  >= e  = S.empty               -- empty interval+      | ps > pe  = scan tr l (d+1) (s,e) -- reached end, scan next+      | closed (l `at` tr (d,ps)) =+                   let ne = (fromIntegral ps - (1%2)) / (fromIntegral d + (1%2))+                   in  scan tr l (d+1) (s,ne) `S.union` scan' Nothing (ps+1) pe+                                      -- entering shadow+      | otherwise = scan' (Just s) (ps+1) pe+                                      -- continue in light+    scan' Nothing ps pe+      | ps > pe  = S.empty            -- reached end while in shadow+      | open (l `at` tr (d,ps)) =+                   let ns = (fromIntegral ps - (1%2)) / (fromIntegral d - (1%2))+                   in  scan' (Just ns) (ps+1) pe+                                      -- moving out of shadow+      | otherwise = scan' 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))+++-- 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 above. In the result, this algorithm is much faster+-- on dense maps, since it does not scan areas blocked by shadows.+-- See https://github.com/Mikolaj/LambdaHack/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.+pscan :: Distance -> (Bump -> Loc) -> LMap -> Distance -> EdgeInterval ->+         Set Loc+pscan r ptr l d (s@(sl{-shallow line-}, sBumps), e@(el{-steep line-}, eBumps)) =+  -- trace (show (d,s,e,ps,pe)) $+  if illegal+  then S.empty+  else S.union outside (S.fromList [tr (d, p) | p <- [ps..pe]])+    -- the area is diagonal, which is incorrect, but looks good enough+    where+      (ns, ks) = pintersect sl d+      (ne, ke) = pintersect el d+      -- Corners are translucent, so they are invisible, so if intersection+      -- is at a corner, choose pe that creates the smaller view.+      (ps, 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) = pintersect sl 0+                 in  ns*ke == ne*ks && (n == 0 || n == k)+      outside+        | d >= r = S.empty+        | open (l `at` tr (d, ps)) = pscan' (Just s) ps  -- start in light+        | ps == ns `divUp` ks = pscan' (Just s) ps       -- start in a corner+        | otherwise = pscan' Nothing (ps+1)              -- start in mid-wall++      dp2bump     (d, p) = B(p, d - p)+      bottomRight (d, p) = B(p, d - p + 1)+      tr = ptr . dp2bump++      pscan' :: Maybe Edge -> Progress -> Set Loc+      pscan' (Just s@(_, sBumps)) ps+        | ps > pe =                            -- reached end, scan next+            pscan r ptr l (d+1) (s, e)+        | closed (l `at` tr (d, ps)) =         -- entering shadow, steep bump+            let steepBump = bottomRight (d, ps)+                gte = flip $ psteeper steepBump+                -- sBumps may contain steepBump, but maximal will ignore it+                nep = maximal gte sBumps+                neBumps = addHull gte steepBump eBumps+            in  S.union+                  (pscan r ptr l (d+1) (s, (pline nep steepBump, neBumps)))+                  (pscan' Nothing (ps+1))+        | otherwise = pscan' (Just s) (ps+1)   -- continue in light++      pscan' 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 (d, ps)+                gte = psteeper shallowBump+                nsp = maximal gte eBumps+                nsBumps = addHull gte shallowBump sBumps+            in  pscan' (Just (pline nsp shallowBump, nsBumps)) ps++      pline p1 p2 =+        pdebugLine $  -- TODO: disable when it becomes a bottleneck+        (p1, p2)++      psteeper f p1 p2 =+        pdebugSteeper f p1 p2 $  -- TODO: disable when it becomes a bottleneck+        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).+pintersect :: Line -> Distance -> (Int, Int)+pintersect (B(y, x), B(yf, xf)) d =+  ((1 + d)*(yf - y) + y*xf - x*yf, (xf - x) + (yf - y))+{-+Derivation of the formula:+The intersection point (yt, xt) 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 shadow casting algorithm above. The line in the curent state+of scan' 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 (Distance, Progress) cordinates+are mangled and not used for geometry.+-}++-- | Debug functions for PFOV:++-- | Debug: calculate steeper for PFOV in another way and compare results.+pdebugSteeper :: Bump ->  Bump -> Bump -> Bool -> Bool+pdebugSteeper f p1 p2 x =+  let (n1, k1) = pintersect (p1, f) 0+      (n2, k2) = pintersect (p2, f) 0+  in  if x == (n1 * k2 <= k1 * n2)+      then x+      else error $ "psteeper: " ++ show (f, p1, p2, x)++-- | Debug: checks postconditions of borderLine.+pdebugLine :: Line -> Line+pdebugLine line@(B(y1, x1), B(y2, x2))+  | y1 == y2 && x1 == x2 =+      error $ "pdebugLine: wrongly defined line " ++ show line+  | x2 - x1 == - (y2 - y1) =+      error $ "pdebugLine: diagonal line " ++ show line+  | crossL0 =+      error $ "pdebugLine: crosses diagonal below 0 " ++ show line+  | crossG1 =+      error $ "pdebugLine: crosses diagonal above 1 " ++ show line+  | otherwise = line+    where+      (n, k)  = pintersect 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)+++-- 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/LambdaHack/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.+dscan :: Distance -> (Bump -> Loc) -> LMap -> Distance -> EdgeInterval ->+         Set Loc+dscan r tr l d (s@(sl{-shallow line-}, sBumps), e@(el{-steep line-}, eBumps)) =+  -- trace (show (d,s,e,ps,pe)) $+  S.union outside (S.fromList [tr (B(d, p)) | p <- [ps..pe]])+    -- the scanned area is a square, which is a sphere in this metric; good+    where+      ps = let (n, k) = dintersect sl d       -- minimal progress to check+           in  n `div` k+      pe = let (n, k) = dintersect el d       -- maximal progress to check+               -- Corners obstruct view, so the steep line, constructed+               -- from corners, is itself not a part of the view,+               -- so if its intersection with the line of diagonals is only+               -- at a corner, choose the diamond leading to a smaller view.+           in  -1 + n `divUp` k+      outside+        | d >= r = S.empty+        | ps > pe = error $ "dscan: wrong start " ++ show (d, (ps, pe))+        | open (l `at` tr (B(d, ps))) =+            dscan' (Just s) (ps+1)            -- start in light, jump ahead+        | otherwise = dscan' Nothing (ps+1)   -- start in shadow, jump ahead++      dscan' :: Maybe Edge -> Progress -> Set Loc+      dscan' (Just s@(_, sBumps)) ps+        | ps > pe = dscan r tr l (d+1) (s, e) -- reached end, scan next+        | closed (l `at` tr steepBump) =      -- entering shadow+            S.union+              (dscan r tr l (d+1) (s, (dline nep steepBump, neBumps)))+              (dscan' Nothing (ps+1))+        | otherwise = dscan' (Just s) (ps+1)  -- continue in light+        where+          steepBump = B(d, ps)+          gte = dsteeper steepBump+          nep = maximal gte sBumps+          neBumps = addHull gte steepBump eBumps++      dscan' Nothing ps+        | ps > pe = S.empty                   -- reached end while in shadow+        | open (l `at` tr shallowBump) =      -- moving out of shadow+            dscan' (Just (dline nsp shallowBump, nsBumps)) (ps+1)+        | otherwise = dscan' Nothing (ps+1)   -- continue in shadow+        where+          shallowBump = B(d, ps)+          gte = flip $ dsteeper shallowBump+          nsp = maximal gte eBumps+          nsBumps = addHull gte shallowBump sBumps++      dline p1 p2 =+        ddebugLine $  -- TODO: disable when it becomes a bottleneck+        (p1, p2)++      dsteeper f p1 p2 =+        ddebugSteeper f p1 p2 $  -- TODO: disable when it becomes a bottleneck+        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).+dintersect :: Line -> Distance -> (Int, Int)+dintersect (B(y, x), B(yf, xf)) d =+  ((d - y)*(xf - x) + x*(yf - y), yf - y)+{-+Derivation of the formula:+The intersection point (yt, xt) 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 shadow casting algorithm above and reversed wrt PFOV.+The line in the curent state of scan' 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 roatated quadrant, the (Distance, Progress) cordinates+coincide with the Bump coordinates, unlike in PFOV.+-}++-- | Debug functions for DFOV:++-- | Debug: calculate steeper for DFOV in another way and compare results.+ddebugSteeper :: Bump ->  Bump -> Bump -> Bool -> Bool+ddebugSteeper f p1 p2 x =+  let (n1, k1) = dintersect (p1, f) 0+      (n2, k2) = dintersect (p2, f) 0+  in  if x == (n1 * k2 >= k1 * n2)+      then x+      else error $ "dsteeper: " ++ show (f, p1, p2, x)++-- | Debug: check is a view border line for DFOV is legal.+ddebugLine :: Line -> Line+ddebugLine line@(B(y1, x1), B(y2, x2))+  | y1 == y2 && x1 == x2 =+      error $ "ddebugLine: wrongly defined line " ++ show line+  | y2 - y1 == 0 =+      error $ "ddebugLine: horizontal line " ++ show line+  | crossL0 =+      error $ "ddebugLine: crosses the X axis below 0 " ++ show line+  | crossG1 =+      error $ "ddebugLine: crosses the X axis above 1 " ++ show line+  | otherwise = line+    where+      (n, k)  = dintersect 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)
+ src/File.hs view
@@ -0,0 +1,22 @@+module File where++import System.IO+import Data.Binary+import qualified Data.ByteString.Lazy as LBS+import Codec.Compression.Zlib as Z++strictReadCompressedFile :: FilePath -> IO LBS.ByteString+strictReadCompressedFile f =+    do+      h <- openBinaryFile f ReadMode+      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++encodeCompressedFile :: Binary a => FilePath -> a -> IO ()+encodeCompressedFile f = LBS.writeFile f . Z.compress . encode+  -- note that LBS.writeFile opens the file in binary mode+
+ src/Frequency.hs view
@@ -0,0 +1,31 @@+module Frequency where++import Control.Monad++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))
+ src/Geometry.hs view
@@ -0,0 +1,71 @@+module Geometry where++-- | Game time in turns. (Placement in module Geometry is not ideal.)+type Time = Int++type X = Int+type Y = Int++type Loc  = (Y,X)+type Dir  = (Y,X)+type Area = ((Y,X),(Y,X))++-- | Given two 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 :: (Loc,Loc) -> Dir+towards ((y0,x0),(y1,x1)) =+  let dy = y1 - y0+      dx = x1 - x0+      angle = atan (fromIntegral dy / fromIntegral dx) / (pi / 2)+      dir | angle <= -0.75 = (-1,0)+          | angle <= -0.25 = (-1,1)+          | angle <= 0.25  = (0,1)+          | angle <= 0.75  = (1,1)+          | angle <= 1.25  = (1,0)+          | otherwise      = (0,0)+  in  if dx >= 0 then dir else neg dir++-- | Get the squared distance between two locations.+distance :: (Loc,Loc) -> Int+distance ((y0,x0),(y1,x1)) = (y1 - y0)^2 + (x1 - x0)^2++-- | Return whether two locations are adjacent on the map+-- (horizontally, vertically or diagonally). Currrently, a+-- position is also considered adjacent to itself.+adjacent :: Loc -> Loc -> Bool+adjacent s t = distance (s,t) <= 2++-- | Return the 8 surrounding locations of a given location.+surroundings :: Loc -> [Loc]+surroundings l = map (l `shift`) moves++diagonal :: Dir -> Bool+diagonal (y,x) = y*x /= 0++-- | Move one square in the given direction.+shift :: Loc -> Dir -> Loc+shift (y0,x0) (y1,x1) = (y0+y1,x0+x1)++-- | Invert a direction (vector).+neg :: Dir -> Dir+neg (y,x) = (-y,-x)++-- | Get the vectors of all the moves.+moves :: [Dir]+moves = [ (x,y) | x <- [-1..1], y <- [-1..1], x /= 0 || y /= 0 ]++up, down, left, right :: Dir+upleft, upright, downleft, downright :: Dir+upleft    = up   `shift` left+upright   = up   `shift` right+downleft  = down `shift` left+downright = down `shift` right+up        = (-1,0)+down      = (1,0)+left      = (0,-1)+right     = (0,1)++horiz, vert :: [Dir]+horiz = [left, right]+vert  = [up, down]
+ src/Grammar.hs view
@@ -0,0 +1,56 @@+module Grammar where++import Data.Char++import Item+import Monster+import State+import ItemState++-- | How to refer to a monster in object position of a sentence.+objectMonster :: MonsterType -> String+objectMonster Player  = "you"+objectMonster Eye     = "the reducible eye"+objectMonster FastEye = "the super-fast eye"+objectMonster Nose    = "the point-free nose"++-- | How to refer to a monster in subject position of a sentence.+subjectMonster :: MonsterType -> String+subjectMonster x = let (s:r) = objectMonster x in toUpper s : r++verbMonster :: MonsterType -> String -> String+verbMonster Player v = v+verbMonster _      v = v ++ "s"++compoundVerbMonster :: MonsterType -> String -> String -> String+compoundVerbMonster Player v p = v ++ " " ++ p+compoundVerbMonster _      v p = v ++ "s " ++ p++objectItem :: State -> Int -> ItemType -> String+objectItem _ n Ring       = makeObject n id "ring"+objectItem _ n Scroll     = makeObject n id "scroll"+objectItem s n (Potion t) = makeObject n (identified (sassocs s) (sdiscoveries s) (Potion t)) "potion"+objectItem _ n Wand       = makeObject n id "wand"+objectItem _ n Amulet     = makeObject n id "amulet"+objectItem _ n Gem        = makeObject n id "gem"+objectItem _ n Gold       = makeObject n id "gold piece"+objectItem _ n (Sword i)  = makeObject n id ("(+" ++ show i ++ ") sword")++subjectVerbIObject :: State -> Monster -> String -> Item -> String -> String+subjectVerbIObject state m v o add =+  subjectMonster (mtype m) ++ " " +++  verbMonster (mtype m) v ++ " " +++  objectItem state (icount o) (itype o) ++ add ++ "."++subjectVerbMObject :: State -> Monster -> String -> Monster -> String -> String+subjectVerbMObject state m v o add =+  subjectMonster (mtype m) ++ " " +++  verbMonster (mtype m) v ++ " " +++  objectMonster (mtype o) ++ add ++ "."++subjectCompoundVerbIObject :: State -> Monster -> String -> String ->+                             Item -> String -> String+subjectCompoundVerbIObject state m v p o add =+  subjectMonster (mtype m) ++ " " +++  compoundVerbMonster (mtype m) v p ++ " " +++  objectItem state (icount o) (itype o) ++ add ++ "."
+ src/HighScores.hs view
@@ -0,0 +1,147 @@+module HighScores where++import System.Directory+import Control.Exception as E hiding (handle)+import Text.Printf+import System.Time++import Data.Binary+import Data.List as L+import Data.Maybe++import File+import Dungeon+import qualified Config++-- | A single score.+-- TODO: add hero's name, 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,+                       current :: Int,+                       killed  :: Bool,+                       victor  :: Bool}+  deriving (Eq, Ord)++instance Binary ClockTime where+  put (TOD s p) =+    do+      put s+      put p+  get =+    do+      s <- get+      p <- get+      return (TOD s p)++instance Binary ScoreRecord where+  put (ScoreRecord points negTurn date current killed victor) =+    do+      put points+      put negTurn+      put date+      put current+      put killed+      put victor+  get =+    do+      points <- get+      negTurn <- get+      date <- get+      current <- get+      killed <- get+      victor <- get+      return (ScoreRecord points negTurn date current killed victor)++-- | Show a single high score.+showScore :: (Int, ScoreRecord) -> String+showScore (pos, score) =+  let won  = if victor score+             then "emerged victorious"+             else "is camping on level " ++ show (current score) ++ ","+      died = if killed score+             then "perished on level " ++ show (current score) ++ ","+             else won+      time = calendarTimeToString . toUTCTime . date $ score+      big  = "                                                 "+      lil  = "              "+  in+   printf "%s\n%4d. %6d  This hero %s after %d steps  \n%son %s.  \n"+     big pos (points score) died (- (negTurn score)) 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 "LambdaHack.scores" "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+    E.catch (removeFile f) (\ e -> case e :: IOException of _ -> return ())+    encodeCompressedFile f (scores, False)++-- | Read the high scores table. Return the empty table if no file.+restore :: Config.CP -> IO ScoreTable+restore config =+  E.catch (do+             f <- file config+             (x, z) <- strictDecodeCompressedFile f+             (z :: Bool) `seq` return x)+          (\ e -> case e :: IOException of+                    _ -> return [])++-- | 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 (\ x -> x > 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+        (lines, _) = normalLevelSize+        height = lines `div` 3+        (msgCurrent, msgUnless) =+          if killed s+          then (" short-lived", " (score halved)")+          else if victor s+               then (" glorious",+                     if pos <= height then " among the greatest heroes" else "")+               else (" current", " (unless you are slain)")+        msg = printf "Your%s exploits award you place >> %d <<%s." msgCurrent pos msgUnless+    if write then save config h' else return ()+    return (msg, slideshow pos h' height)
+ src/Item.hs view
@@ -0,0 +1,255 @@+module Item where++import Data.Binary+import Data.Map as M+import Data.Set as S+import Data.List as L+import Data.Maybe+import Data.Char+import Data.Function+import Control.Monad++import Display+import Geometry+import Random++data Item = Item+             { icount  :: Int,+               itype   :: ItemType,+               iletter :: Maybe Char }  -- inventory identifier+  deriving Show++data ItemType =+   Ring+ | Scroll+ | Potion PotionType+ | Wand+ | Amulet+ | Gem+ | Gold+ | Sword Int+ deriving (Eq, Ord, Show)++data PotionType =+   PotionWater+ | PotionHealing+ deriving (Eq, Ord, Show)++data Appearance =+   Clear+ | White+ deriving (Eq, Show)++type Assocs = M.Map ItemType Appearance+type Discoveries = S.Set ItemType++equalItemType :: Item -> Item -> Bool+equalItemType = (==) `on` itype++equalItemLetter :: Item -> Item -> Bool+equalItemLetter = (==) `on` iletter++potionType :: PotionType -> String -> String+potionType PotionWater   s = s ++ " of water"+potionType PotionHealing s = s ++ " of healing"++appearance :: Appearance -> String -> String+appearance Clear s = "clear " ++ s+appearance White s = "white " ++ s++instance Binary Item where+  put (Item icount itype iletter) = put icount >> put itype >> put iletter+  get = liftM3 Item get get get++instance Binary ItemType where+  put Ring       = putWord8 0+  put Scroll     = putWord8 1+  put (Potion t) = putWord8 2 >> put t+  put Wand       = putWord8 3+  put Amulet     = putWord8 4+  put Gem        = putWord8 5+  put Gold       = putWord8 6+  put (Sword i)  = putWord8 7 >> put i+  get = do+          tag <- getWord8+          case tag of+            0 -> return Ring+            1 -> return Scroll+            2 -> liftM Potion get+            3 -> return Wand+            4 -> return Amulet+            5 -> return Gem+            6 -> return Gold+            7 -> liftM Sword get++instance Binary PotionType where+  put PotionWater   = putWord8 0+  put PotionHealing = putWord8 1+  get = do+          tag <- getWord8+          case tag of+            0 -> return PotionWater+            1 -> return PotionHealing++instance Binary Appearance where+  put Clear = putWord8 0+  put White = putWord8 1+  get = do+          tag <- getWord8+          case tag of+            0 -> return Clear+            1 -> return White++itemFrequency :: Frequency ItemType+itemFrequency =+  Frequency+  [+    (100, Gold),+    (70,  Sword (-1)),+    (30,  Gem),+    (20,  Ring),+    (30,  Scroll),+    (10,  Wand),+    (10,  Amulet),+    (30,  Potion PotionWater),+    (20,  Potion PotionHealing)+  ]++itemQuantity :: Int -> ItemType -> Rnd Int+itemQuantity n Gold = (2 * n) *~ d 8+itemQuantity _ _    = return 1++itemStrength :: Int -> ItemType -> Rnd ItemType+itemStrength n (Sword _) =+  do+    r <- d (2 + n `div` 2)+    return $ Sword $ (n + 1) `div` 3 + r+itemStrength _ tp        = return tp++itemLetter :: ItemType -> Maybe Char+itemLetter Gold = Just '$'+itemLetter _    = Nothing++-- | Generate an item.+newItem :: Int -> Frequency ItemType -> Rnd Item+newItem n ftp =+  do+    tp <- frequency ftp+    item <- itemStrength n tp+    nr <- itemQuantity n tp+    return (Item nr item (itemLetter tp))++-- | Assigns a letter to an item, for inclusion+-- in the inventory of the player. 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 (concatMap (maybeToList . iletter) 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 = maxBy cmpLetter++mergeLetter :: Maybe Char -> Maybe Char -> Maybe Char+mergeLetter = mplus++letterRange :: [Char] -> String+letterRange xs = sectionBy (sortBy cmpLetter xs) 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 : " - "++viewItem :: ItemType -> Assocs -> (Char, Attr -> Attr)+viewItem i a = viewItem' i (M.lookup i a)+  where+    viewItem' (Sword {})  _            = (')', id)+    viewItem' Ring        _            = ('=', id)+    viewItem' Scroll      _            = ('?', id)+    viewItem' (Potion {}) (Just Clear) = ('!', setBold . setFG blue)+    viewItem' (Potion {}) (Just White) = ('!', setBold . setFG white)+    viewItem' (Potion {}) _            = ('!', id)+    viewItem' Wand        _            = ('/', id)+    viewItem' Gold        _            = ('$', setBold . setFG yellow)+    viewItem' Gem         _            = ('*', setFG red)+    viewItem' Amulet      _            = ('"', id)+    viewItem' _           _            = ('~', id)++-- | Adds an item to a list of items, joining equal items.+-- Also returns the joined item.+joinItem :: Item -> [Item] -> (Item,[Item])+joinItem i is = case findItem (equalItemType i) is of+                  Nothing     -> (i, i : is)+                  Just (j,js) -> let n = i { icount = icount i + icount j,+                                             iletter = mergeLetter (iletter j) (iletter i) }+                                 in (n, n : js)++-- | Removes an item from a list of items. Takes an equality function (i.e., by letter or+-- by type) as an argument.+removeItemBy :: (Item -> Item -> Bool) -> Item -> [Item] -> [Item]+removeItemBy eq i = concatMap $ \ x ->+                    if eq i x+                      then let remaining = icount x - icount i+                           in  if remaining > 0+                                 then [x { icount = remaining }]+                                 else []+                      else [x]++removeItemByLetter = removeItemBy equalItemLetter+removeItemByType   = removeItemBy equalItemType++-- | Finds an item in a list of items.+findItem :: (Item -> Bool) -> [Item] -> Maybe (Item, [Item])+findItem p is = findItem' [] is+  where+    findItem' acc []     = Nothing+    findItem' acc (i:is)+      | p i              = Just (i, reverse acc ++ is)+      | otherwise        = findItem' (i:acc) is++strongestSword :: [Item] -> Int+strongestSword l =+  let aux acc (Item { itype = Sword i }) = max acc i+      aux acc _ = acc+  in  foldl aux 0 l++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 (obj ++ "s")
+ src/ItemState.hs view
@@ -0,0 +1,16 @@+module ItemState where++import Data.Set as S+import Data.Map as M++import Item+import State++identified :: Assocs -> Discoveries -> ItemType -> String -> String+identified a d i+  | i `S.member` d = case i of+                       Potion t -> potionType t+                       _        -> ("really strange " ++)+  | otherwise      = case M.lookup i a of+                       Just ap  -> appearance ap+                       _        -> ("really strange " ++)
+ src/Keybindings.hs view
@@ -0,0 +1,40 @@+module Keybindings where++import Control.Monad+import Control.Monad.State hiding (State)+import Data.Map as M++import Action+import Command+import Display2+import Keys as K++-- | Keybindings.+data Keybindings = Keybindings+  { kdir   :: DirCommand,+    kudir  :: DirCommand,+    kother :: M.Map K.Key Command+  }++handleKey :: Keybindings -> K.Key -> Action ()+handleKey kb k =+  do+    handleDirection k (caction $ kdir kb) $+      handleUDirection k (caction $ kudir kb) $+        case M.lookup k (kother kb) of+          Just c  -> caction c+          Nothing -> abortWith $ "unknown command (" ++ K.showKey k ++ ")"++keyHelp :: Keybindings -> String+keyHelp kb =+  let+    fmt k h = replicate 15 ' ' ++ k ++ replicate ((13 - length k) `max` 1) ' ' +++                                  h ++ replicate ((30 - length h) `max` 1) ' '+    fmts s  = replicate 15 ' ' ++ s ++ replicate ((43 - length s) `max` 1) ' '+    blank   = fmt "" ""+    title   = fmt "key" "command"+    footer  = fmts "(See file PLAYING.markdown.)"+    rest    = [ fmt (K.showKey k) h | (k, Described h _) <- M.toAscList (kother kb) ]+  in+    unlines ([blank, title] ++ rest ++ [blank, footer, blank])+
+ src/Keys.hs view
@@ -0,0 +1,32 @@+module Keys where++import Prelude hiding (Left, Right)++-- | Library-independent datatype to represent keys.+data Key =+    Esc+  | Return+  | PgUp+  | PgDn+  | Left+  | Right+  | Up+  | Down+  | End+  | Begin+  | Home+  | Char Char    -- ^ a single printable character+  deriving (Ord, Eq)++showKey :: Key -> String+showKey (Char c) = [c]+showKey Esc      = "<escape>"+showKey Return   = "<return>"+showKey PgUp     = "<page-up>"+showKey PgDn     = "<page-down>"+showKey Left     = "<left>"+showKey Right    = "<right>"+showKey Up       = "<up>"+showKey Down     = "<down>"+showKey End      = "<end>"+showKey Home     = "<home>"
+ src/LambdaHack.hs view
@@ -0,0 +1,79 @@+module Main where++import System.Directory+import Control.Monad+import Data.Map as M+import Data.Maybe++import Action+import State+import Geometry+import Level+import Dungeon+import Perception+import Display2+import Random+import qualified Save+import Turn+import Item+import qualified Config++main :: IO ()+main = startup start++-- | Either restore a saved game, or setup a new game.+start :: Session -> IO ()+start session =+    do+      -- check if we have a savegame+      config <- Config.config+      f <- Save.file config+      x <- doesFileExist f+      restored <- if x then do+                              displayBlankConfirm session "Restoring save game"+                              Save.restoreGame config+                       else return $ Right "Welcome to LambdaHack!"  -- new game+      case restored of+        Right msg  -> generate config session msg+        Left state -> handlerToIO session state "Welcome back to LambdaHack."+                        handle++-- | Generate the dungeon for a new game, and start the game loop.+generate :: Config.CP -> Session -> String -> IO ()+generate config session msg =+  let matchGenerator n Nothing =+        if n == 3 then bigroom else+          if n == 10 then noiseroom else  -- access to stairs may be blocked+            level+      matchGenerator n (Just "bigroom")   = bigroom+      matchGenerator n (Just "noiseroom") = noiseroom+      matchGenerator n (Just s) =+        error $ "findGenerator: unknown: " ++ show n ++ ", " ++ s++      findGenerator n =+        let genName = Config.getOption config "dungeon" ("level" ++ show n)+            generator = matchGenerator n genName+        in  rndToIO $ generator (defaultLevelConfig n) (LambdaCave n)++      connect :: Maybe (Maybe DungeonLoc) ->+                 [(Maybe (Maybe DungeonLoc) -> Maybe (Maybe DungeonLoc) ->+                   Level, Loc, Loc)] ->+                 [Level]+      connect au [(x,_,_)] = [x au Nothing]+      connect au ((x,_,d):ys@((_,u,_):_)) =+        let (z:zs) = connect (Just (Just (lname x',d))) ys+            x'     = x au (Just (Just (lname z,u)))+        in  x' : z : zs+  in+   do+     let depth = fromMaybe 10 $ Config.getOption config "dungeon" "depth"+     levels <- mapM findGenerator [1..depth]+     let lvls = connect (Just Nothing) levels+         (lvl,dng) = (head lvls, dungeon (tail lvls))+         -- generate item associations+         assocs = M.fromList+                    [ (Potion PotionWater,   Clear),+                      (Potion PotionHealing, White) ]+         defState = defaultState ((\ (_,x,_) -> x) (head levels)) dng lvl+         state = defState { sassocs = assocs, config = config }+     handlerToIO session state msg handle
+ src/Level.hs view
@@ -0,0 +1,545 @@+module Level where++import qualified System.Random as R+import Control.Monad++import Data.Binary+import Data.Binary.Put+import Data.Binary.Get+import Data.Map as M+import Data.Set as S+import Data.List as L+import Data.Ratio+import Data.Maybe++import Geometry+import Monster+import Item+import Random+import Display++-- | Names of the dungeon levels are represented using a+-- custom data structure.+data LevelName = LambdaCave Int | Exit+  deriving (Show, Eq, Ord)++-- | 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 :: LevelName -> [Monster] -> Rnd Bool+monsterGenChance (LambdaCave n) [] = chance $ 1%25+monsterGenChance (LambdaCave n) l  = chance $ 1%((400 + (fromIntegral (L.length l) * 100) - (fromIntegral n * 50)) `max` 50)+monsterGenChance _              _  = return False++instance Binary LevelName where+  put (LambdaCave n) = put n+  get = liftM LambdaCave get++-- | Provide a textual description of a level name.+levelName :: LevelName -> String+levelName (LambdaCave n) = "The Lambda Cave " ++ show n++-- | Gives the numeric representation of the level's depth.+levelNumber :: LevelName -> Int+levelNumber (LambdaCave n) = n++-- | The complete dungeon is a map from level names to levels.+-- We usually store all but the current level in this data structure.+data Dungeon = Dungeon (M.Map LevelName Level)+  deriving Show++-- | Create a dungeon from a list of levels.+dungeon :: [Level] -> Dungeon+dungeon = Dungeon . M.fromList . L.map (\ l -> (lname l, l))++-- | Extract a level from a dungeon.+getDungeonLevel :: LevelName -> Dungeon -> (Level, Dungeon)+getDungeonLevel ln (Dungeon dng) = (fromJust (M.lookup ln dng), Dungeon (M.delete ln dng))++-- | Put a level into a dungeon.+putDungeonLevel :: Level -> Dungeon -> Dungeon+putDungeonLevel lvl (Dungeon dng) = Dungeon (M.insert (lname lvl) lvl dng)++instance Binary Dungeon where+  put (Dungeon dng) = put (M.elems dng)+  get = liftM dungeon get++-- | A dungeon location is a level together with a location on+-- that level.+type DungeonLoc = (LevelName, Loc)++data Level = Level+              { lname     :: LevelName,+                lsize     :: (Y,X),+                lmonsters :: [Monster],+                lsmell    :: SMap,+                lmap      :: LMap,+                lmeta     :: String }+  deriving Show++updateLMap :: (LMap -> LMap) -> Level -> Level+updateLMap f lvl = lvl { lmap = f (lmap lvl) }++updateSMap :: (SMap -> SMap) -> Level -> Level+updateSMap f lvl = lvl { lsmell = f (lsmell lvl) }++updateMonsters :: ([Monster] -> [Monster]) -> Level -> Level+updateMonsters f lvl = lvl { lmonsters = f (lmonsters lvl) }++instance Binary Level where+  put (Level nm sz@(sy,sx) ms lsmell lmap lmeta) =+        do+          put nm+          put sz+          put ms+          put [ lsmell ! (y,x) | y <- [0..sy], x <- [0..sx] ]+          put [ lmap ! (y,x) | y <- [0..sy], x <- [0..sx] ]+          put lmeta+  get = do+          nm <- get+          sz@(sy,sx) <- get+          ms <- get+          xs <- get+          let lsmell = M.fromList (zip [ (y,x) | y <- [0..sy], x <- [0..sx] ] xs)+          xs <- get+          let lmap   = M.fromList (zip [ (y,x) | y <- [0..sy], x <- [0..sx] ] xs)+          lmeta <- get+          return (Level nm sz ms lsmell lmap lmeta)++type LMap = Map (Y,X) (Tile,Tile)+type SMap = Map (Y,X) Time++data Tile = Tile+              { tterrain :: Terrain,+                titems   :: [Item] }+  deriving Show++instance Binary Tile where+  put (Tile t is) = put t >> put is+  get = liftM2 Tile get get++at         l p = fst (findWithDefault (unknown, unknown) p l)+rememberAt l p = snd (findWithDefault (unknown, unknown) p l)++unknown :: Tile+unknown = Tile Unknown []++data Terrain = Rock+             | Opening Pos+             | Floor DL+             | Unknown+             | Corridor+             | Wall Pos+             | Stairs DL VDir (Maybe DungeonLoc)+             | Door Pos (Maybe Int)  -- Nothing: open, Just 0: closed, otherwise secret+  deriving Show++instance Binary Terrain where+  put Rock            = putWord8 0+  put (Opening p)     = putWord8 1 >> put p+  put (Floor dl)      = putWord8 2 >> put dl+  put Unknown         = putWord8 3+  put Corridor        = putWord8 4+  put (Wall p)        = putWord8 5 >> put p+  put (Stairs dl d n) = putWord8 6 >> put dl >> put d >> put n+  put (Door p o)      = putWord8 7 >> put p >> put o+  get = do+          tag <- getWord8+          case tag of+            0 -> return Rock+            1 -> liftM Opening get+            2 -> liftM Floor get+            3 -> return Unknown+            4 -> return Corridor+            5 -> liftM Wall get+            6 -> liftM3 Stairs get get get+            7 -> liftM2 Door get get+            _ -> fail "no parse (Tile)"++data DL = Dark | Light+  deriving (Eq, Show, Bounded)++-- | All the wall types that are possible:+--+--     * 'UL': upper left+--+--     * 'U': upper+--+--     * 'UR': upper right+--+--     * 'L': left+--+--     * 'R': right+--+--     * 'DL': lower left+--+--     * 'D': lower+--+--     * 'DR': lower right+--+--     * 'O': lower right+--+-- I am tempted to add even more (T-pieces and crossings),+-- but currently, we don't need them.+data Pos = UL | U | UR | L | R | DL | D | DR | O+  deriving (Eq, Show, Bounded)++instance Binary Pos where+  put UL = putWord16le 0+  put U  = putWord16le 1+  put UR = putWord16le 2+  put L  = putWord16le 3+  put R  = putWord16le 4+  put DL = putWord16le 5+  put D  = putWord16le 6+  put DR = putWord16le 7+  put O  = putWord16le 8++  get = do+          tag <- getWord16le+          case tag of+            0 -> return UL+            1 -> return U+            2 -> return UR+            3 -> return L+            4 -> return R+            5 -> return DL+            6 -> return D+            7 -> return DR+            8 -> return O++data HV = Horiz | Vert+  deriving (Eq, Show, Bounded)++fromHV Horiz = True+fromHV Vert  = False++toHV True  = Horiz+toHV False = Vert++instance R.Random HV where+  randomR (a,b) g = case R.randomR (fromHV a,fromHV b) g of+                      (b,g') -> (toHV b,g')+  random g = R.randomR (minBound, maxBound) g++instance Binary HV where+  put Horiz = put True+  put Vert  = put False+  get = get >>= \ b -> if b then return Horiz else return Vert++instance Binary DL where+  put Dark  = put False+  put Light = put True+  get = get >>= \ b -> if b then return Light else return Dark++data VDir = Up | Down+  deriving (Eq, Show)++instance Binary VDir where+  put Up   = put True+  put Down = put False+  get = get >>= \ b -> if b then return Up else return Down++instance Eq Terrain where+  Rock == Rock = True+  Opening d == Opening d' = d == d'+  Floor l == Floor l' = l == l'+  Unknown == Unknown = True+  Corridor == Corridor = True+  Wall p == Wall p' = p == p'+  Stairs dl d t == Stairs dl' d' t' = dl == dl' && d == d' && t == t'+  Door p o == Door p' o' = p == p' && o == o'+  _ == _ = False++-- | blocks moves and vision+closed :: Tile -> Bool+closed = not . open++floor :: Tile -> Bool+floor (Tile { tterrain = Floor _ }) = True+floor _                             = False++secret :: Maybe Int -> Bool+secret (Just n) | n /= 0 = True+secret _ = False++toOpen :: Bool -> Maybe Int+toOpen True = Nothing+toOpen False = Just 0++fromDL :: DL -> Bool+fromDL Dark = False+fromDL Light = True++toDL :: Bool -> DL+toDL False = Dark+toDL True  = Light++-- | allows moves and vision+open :: Tile -> Bool+open (Tile (Floor {}) _)     = True+open (Tile (Opening {}) _)   = True+open (Tile (Door _ o) _)     = isNothing o+open (Tile Corridor _)       = True+open (Tile (Stairs {}) _)    = True+open _                       = False++-- | is lighted on its own+light :: Tile -> Bool+light (Tile (Floor l) _)        = fromDL l+light (Tile (Stairs l _ _) _)   = fromDL l+light _                         = False++-- | can be lighted by sourrounding tiles+reflects :: Tile -> Bool+reflects (Tile (Opening _) _) = True+reflects (Tile (Wall _) _)    = True+reflects (Tile (Door _ _) _)  = True+reflects _                    = False++-- | Passive tiles reflect light from some other (usually adjacent)+-- positions. This function returns the offsets from which light is+-- reflected. Not all passively lighted tiles reflect from all directions.+-- Walls, for instance, cannot usually be seen from the outside.+passive :: Tile -> [Dir]+passive (Tile (Wall p) _)          = posToDir p+passive (Tile (Opening _) _)       = moves+passive (Tile (Door p Nothing) _)  = moves+passive (Tile (Door p (Just 0)) _) = moves+                                     -- doors can be seen from all sides+passive (Tile (Door p (Just n)) _) = posToDir p+                                     -- secret doors are like walls+passive (Tile (Stairs _ _ _) _)    = moves+passive _                          = []++-- | Perceptible is similar to passive, but describes which tiles can+-- be seen from which adjacent fields in the dark.+perceptible :: Tile -> [Dir]+perceptible (Tile Rock _) = []+perceptible p = case passive p of+                 [] -> moves+                 ds -> ds++-- | Maps wall types to lists of expected floor positions.+posToDir :: Pos -> [Dir]+posToDir UL = [downright]+posToDir U  = [down]+posToDir UR = [downleft]+posToDir L  = [right]+posToDir R  = [left]+posToDir DL = [upright]+posToDir D  = [up]+posToDir DR = [upleft]+posToDir O  = moves++-- checks for the presence of monsters (and items); it does *not* check+-- if the tile is open ...+unoccupied :: [Monster] -> LMap -> Loc -> Bool+unoccupied monsters _lmap loc =+  all (\ m -> mloc m /= loc) monsters++-- check whether one location is accessible from the other+-- precondition: the two locations are next to each other+-- currently only implements that doors aren't accessible diagonally,+-- and that the target location has to be open+accessible :: LMap -> Loc -> Loc -> Bool+accessible lmap source target =+  let dir = shift source (neg target)+      src = lmap `at` source+      tgt = lmap `at` target+  in  open tgt &&+      (not (diagonal dir) ||+       case (tterrain src, tterrain tgt) of+         (Door {}, _)  -> False+         (_, Door {})  -> False+         _             -> True)++-- check whether the location contains a door of at most secrecy level k+openable :: Int -> LMap -> Loc -> Bool+openable k lmap target =+  let tgt = lmap `at` target+  in  case tterrain tgt of+        Door _ (Just n) -> n <= k+        _               -> False++findLocInArea :: Area -> (Loc -> Bool) -> Rnd Loc+findLocInArea a@((y0,x0),(y1,x1)) p =+  do+    rx <- randomR (x0,x1)+    ry <- randomR (y0,y1)+    let loc = (ry,rx)+    if p loc then return loc else findLocInArea a p++locInArea :: Area -> Rnd Loc+locInArea a = findLocInArea a (const True)++findLoc :: Level -> (Loc -> Tile -> Bool) -> Rnd Loc+findLoc l@(Level { lsize = sz, lmap = lm }) p =+  do+    loc <- locInArea ((0,0),sz)+    let tile = lm `at` loc+    if p loc tile+      then return loc+      else findLoc l p++findLocTry :: Int ->  -- try k times+              Level ->+              (Loc -> Tile -> Bool) ->  -- loop until satisfied+              (Loc -> Tile -> Bool) ->  -- only try to satisfy k times+              Rnd Loc+findLocTry k l@(Level { lsize = sz, lmap = lm }) p pTry =+  do+    loc <- locInArea ((0,0),sz)+    let tile = lm `at` loc+    if p loc tile && pTry loc tile+      then return loc+      else if k > 1+             then findLocTry (k - 1) l p pTry+             else findLoc l p++grid :: (Y,X) -> Area -> Map (Y,X) Area+grid (ny,nx) ((y0,x0),(y1,x1)) =+  let yd = y1 - y0+      xd = x1 - x0+  in M.fromList [ ((y,x), ((y0 + (yd * y `div` ny), x0 + (xd * x `div` nx)),+                           (y0 + (yd * (y + 1) `div` ny - 1), x0 + (xd * (x + 1) `div` nx - 1))))+                | x <- [0..nx-1], y <- [0..ny-1] ]+++connectGrid :: (Y,X) -> Rnd [((Y,X),(Y,X))]+connectGrid (ny,nx) =+  do+    let unconnected = S.fromList [ (y,x) | 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 [ (ry,rx) ]+    connectGrid' (ny,nx) unconnected candidates []++randomConnection :: (Y,X) -> Rnd ((Y,X),(Y,X))+randomConnection (ny,nx) =+  do+    rb  <- randomR (False,True)+    if rb then do+                 rx  <- randomR (0,nx-2)+                 ry  <- randomR (0,ny-1)+                 return (normalize ((ry,rx),(ry,rx+1)))+          else do+                 ry  <- randomR (0,ny-2)+                 rx  <- randomR (0,nx-1)+                 return (normalize ((ry,rx),(ry+1,rx)))++normalize :: ((Y,X),(Y,X)) -> ((Y,X),(Y,X))+normalize (a,b) | a <= b    = (a,b)+                | otherwise = (b,a)++normalizeArea :: Area -> Area+normalizeArea a@((y0,x0),(y1,x1)) = ((min y0 y1, min x0 x1), (max y0 y1, max x0 x1))++connectGrid' :: (Y,X) -> Set (Y,X) -> Set (Y,X) -> [((Y,X),(Y,X))] -> Rnd [((Y,X),(Y,X))]+connectGrid' (ny,nx) unconnected candidates acc+  | S.null candidates = return (L.map normalize acc)+  | otherwise = do+                  c <- oneOf (S.toList candidates)+                  let ns = neighbors ((0,0),(ny-1,nx-1)) c  -- potential new candidates+                  let nu = S.delete c unconnected  -- new unconnected+                  let (nc,ds) = S.partition (`S.member` nu) ns+                                  -- (new candidates, potential connections)+                  new <- if S.null ds then return id+                                      else do+                                             d <- oneOf (S.toList ds)+                                             return ((c,d) :)+                  connectGrid' (ny,nx) nu+                                       (S.delete c (candidates `S.union` nc)) (new acc)++neighbors :: Area ->        {- size limitation -}+             Loc ->         {- location to find neighbors of -}+             Set Loc+neighbors area (y,x) =+  let cs = [ (y + dy, x + dx) | dy <- [-1..1], dx <- [-1..1], (dx + dy) `mod` 2 == 1 ]+  in  S.fromList (L.filter (`inside` area) cs)++inside :: Loc -> Area -> Bool+inside (y,x) ((y0,x0),(y1,x1)) = x1 >= x && x >= x0 && y1 >= y && y >= y0+++fromTo :: Loc -> Loc -> [Loc]+fromTo (y0,x0) (y1,x1)+  | y0 == y1 = L.map (\ x -> (y0,x)) (fromTo1 x0 x1)+  | x0 == x1 = L.map (\ y -> (y,x0)) (fromTo1 y0 y1)++fromTo1 :: X -> X -> [X]+fromTo1 x0 x1+  | x0 <= x1  = [x0..x1]+  | otherwise = [x0,x0-1..x1]++-- | Produces a textual description for terrain, used if no objects+-- are present.+lookTerrain :: Terrain -> String+lookTerrain (Floor _)          = "Floor."+lookTerrain Corridor           = "Corridor."+lookTerrain (Opening _)        = "An opening."+lookTerrain (Stairs _ Up _)    = "A staircase up."+lookTerrain (Stairs _ Down _)  = "A staircase down."+lookTerrain (Door _ Nothing)   = "An open door."+lookTerrain _                  = ""++-- | The parameter "n" is the level of evolution:+--+-- 0: final+-- 1: stairs added+-- 2: doors added+-- 3: corridors and openings added+-- 4: only rooms+--+-- The Bool indicates whether the loc is currently visible.+viewTerrain :: Int -> Bool -> Terrain -> (Char, Attr -> Attr)+viewTerrain n b Rock              = (' ', id)+viewTerrain n b (Opening d)+  | n <= 3                        = ('.', id)+  | otherwise                     = viewTerrain 0 b (Wall d)+viewTerrain n b (Floor Light)     = ('.', id)+viewTerrain n b (Floor Dark)      = if b then ('.', id) else (' ', id)+viewTerrain n b Unknown           = (' ', id)+viewTerrain n b Corridor+  | n <= 3                        = ('#', id)+  | otherwise                     = viewTerrain 0 b Rock+viewTerrain n b (Wall p)+  | p == O                        = ('O', id)+  | p `elem` [L, R]               = ('|', id)+  | otherwise                     = ('-', id)+viewTerrain n b (Stairs _ Up _)+  | n <= 1                        = ('<', id)+  | otherwise                     = viewTerrain 0 b (Floor Dark)+viewTerrain n b (Stairs _ Down _)+  | n <= 1                        = ('>', id)+  | otherwise                     = viewTerrain 0 b (Floor Dark)+viewTerrain n b (Door d (Just 0))+  | n <= 2                        = ('+', setFG yellow)+  | otherwise                     = viewTerrain n b (Opening d)+viewTerrain n b (Door d (Just _))+  | n <= 2                        = viewTerrain n b (Wall d)  -- secret door+  | otherwise                     = viewTerrain n b (Opening d)+viewTerrain n b (Door p Nothing)+  | n <= 2                        = (if p `elem` [L, R] then '-' else '|', setFG yellow)+  | otherwise                     = viewTerrain n b (Opening p)++viewSmell :: Int -> (Char, Attr -> Attr)+viewSmell n = let k | n > 9    = '*'+                    | n < 0    = '-'+                    | otherwise = head . show $ n+              in  (k, setFG black . setBG green)++-- TODO: Really scatter around, if more than one or location occupied.+--       Scatter randomly or not?+--       Perhaps starting in the direction opposite to the player?+scatterItems :: [Item] -> Loc -> Level -> Level+scatterItems items loc lvl@(Level { lmap = lmap }) =+  let joinItems items = foldl (\ acc i -> snd (joinItem i acc)) items+      t = lmap `at` loc+      nt = t { titems = joinItems items (titems t) }+      ntRemember = lmap `rememberAt` loc+  in  updateLMap (M.insert loc (nt, ntRemember)) lvl
+ src/LevelState.hs view
@@ -0,0 +1,33 @@+module LevelState where++import Display+import Geometry+import Level+import State+import Item+import ItemState+import Grammar++viewTile :: Bool -> Tile -> Assocs -> (Char, Attr -> Attr)+viewTile b (Tile t [])    a = viewTerrain 0 b t+viewTile b (Tile t (i:_)) a = viewItem (itype i) a++-- | Produces a textual description of the items at a location. It's+-- probably correct to use 'at' rather than 'rememberAt' at this point,+-- although we could argue that 'rememberAt' reflects what the player can+-- perceive more correctly ...+--+-- The "detailed" variant is for use with an explicit look command.+lookAt :: Bool -> State -> LMap -> Loc -> String+lookAt detailed s lmap loc+  | detailed  = lookTerrain (tterrain (lmap `at` loc)) ++ " " ++ isd+  | otherwise = isd+  where+    is  = titems (lmap `at` loc)+    isd = case is of+            []    -> ""+            [i]   -> "You see " ++ objectItem s (icount i) (itype i) ++ "."+            [i,j] -> "You see " ++ objectItem s (icount i) (itype i) ++ " and "+                                ++ objectItem s (icount j) (itype j) ++ "."+            _     -> "There are several objects here" +++                     if detailed then ":" else "."
+ src/Message.hs view
@@ -0,0 +1,30 @@+module Message where++import 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
+ src/Monster.hs view
@@ -0,0 +1,134 @@+module Monster where++import Data.Char+import Data.Binary+import Control.Monad++import Geometry+import Display+import Item+import Random++-- | Hit points of the player. TODO: Should not be hardcoded.+playerHP :: Int+playerHP = 50++-- | Time the player can be traced by monsters. TODO: Make configurable.+smellTimeout :: Time+smellTimeout = 1000++-- | Initial player.+defaultPlayer :: Loc -> Player+defaultPlayer ploc =+  Monster Player playerHP playerHP Nothing ploc [] 'a' 10 0++type Player = Monster++data Monster = Monster+                { mtype   :: !MonsterType,+                  mhpmax  :: !Int,+                  mhp     :: !Int,+                  mdir    :: Maybe Dir,  -- for monsters: the dir the monster last moved;+                                         -- for the player: the dir the player is running+                  mloc    :: !Loc,+                  mitems  :: [Item],     -- inventory+                  mletter :: !Char,      -- next inventory letter+                  mspeed  :: !Time,      -- speed (i.e., delay before next action)+                  mtime   :: !Time }     -- time of next action+  deriving Show++instance Binary Monster where+  put (Monster mt mhpm mhp md ml minv mletter mspeed mtime) =+    do+      put mt+      put mhpm+      put mhp+      put md+      put ml+      put minv+      put mletter+      put mspeed+      put mtime+  get = do+          mt      <- get+          mhpm    <- get+          mhp     <- get+          md      <- get+          ml      <- get+          minv    <- get+          mletter <- get+          mspeed  <- get+          mtime   <- get+          return (Monster mt mhpm mhp md ml minv mletter mspeed mtime)++data MonsterType =+    Player+  | Eye+  | FastEye+  | Nose+  deriving (Show, Eq)++instance Binary MonsterType where+  put Player  = putWord8 0+  put Eye     = putWord8 1+  put FastEye = putWord8 2+  put Nose    = putWord8 3+  get = do+          tag <- getWord8+          case tag of+            0 -> return Player+            1 -> return Eye+            2 -> return FastEye+            3 -> return Nose+            _ -> fail "no parse (MonsterType)"++-- | Monster frequencies (TODO: should of course vary much more+-- on local circumstances).+monsterFrequency :: Frequency MonsterType+monsterFrequency =+  Frequency+  [+    (2, Nose),+    (6, Eye),+    (1, FastEye)+  ]++-- | Generate monster.+newMonster :: Loc -> Frequency MonsterType -> Rnd Monster+newMonster loc ftp =+    do+      tp <- frequency ftp+      hp <- hps tp+      let s = speed tp+      return (template tp hp loc s)+  where+    -- 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 tp hp loc s = Monster tp hp hp Nothing loc [] 'a' s 0++    hps Eye      = randomR (1,12)  -- falls in 1--4 unarmed rounds+    hps FastEye  = randomR (1,6)   -- 1--2+    hps Nose     = randomR (6,13)  -- 2--5 and in 1 round of the strongest sword++    speed Eye      = 10+    speed FastEye  = 4+    speed Nose     = 11++-- | Insert a monster in an mtime-sorted list of monsters.+-- Returns the position of the inserted monster and the new list.+insertMonster :: Monster -> [Monster] -> (Int, [Monster])+insertMonster = insertMonster' 0+  where+    insertMonster' n m []      = (n, [m])+    insertMonster' n m (m':ms)+      | mtime m <= mtime m'    = (n, m : m' : ms)+      | otherwise              = let (n', ms') = insertMonster' (n + 1) m ms+                                 in  (n', m' : ms')++viewMonster :: MonsterType -> (Char, Attr -> Attr)+viewMonster Player  = ('@', setBG white . setFG black)+viewMonster Eye     = ('e', setFG red)+viewMonster FastEye = ('e', setFG blue)+viewMonster Nose    = ('n', setFG green)
+ src/Perception.hs view
@@ -0,0 +1,85 @@+module Perception where++import Data.Set as S+import Data.List as L+import Data.Maybe++import Geometry+import State+import Level+import Monster+import FOV+import qualified Config++data Perception =+  Perception { preachable :: Set Loc, pvisible :: Set Loc }++perception_ :: State -> Perception+perception_ (State { splayer = Monster { mloc = ploc },+                     slevel  = Level { lmap = lmap},+                     config  = config,+                     ssensory = ssensory }) =+  let mode   = Config.getOption config "engine" "fov_mode"+      radius = fromMaybe 40 $ Config.getOption config "engine" "fov_radius"+      fovMode =+        -- terrible, temporary hack+        case ssensory of+          Vision 3 -> Diagonal radius+          Vision 2 -> Permissive radius+          Vision 1 -> Shadow+          _        ->+            -- this is not a hack+            case mode of+              Just "permissive" -> Permissive radius+              Just "diagonal"   -> Diagonal radius+              _                 -> Shadow+  in  perception fovMode ploc lmap++perception :: FovMode -> Loc -> LMap -> Perception+perception fovMode ploc lmap =+  let+    -- This part is simple. "reachable" contains everything that is on an+    -- unblocked path from the player position.+    reachable  = fullscan fovMode ploc lmap+    -- In "actVisible", we store the locations that have light and are+    -- reachable. Furthermore, the player location itself is always+    -- visible.+    litVisible = S.filter (\ loc -> light (lmap `at` loc)) reachable+    actVisible = S.insert ploc litVisible+    srnd       = S.fromList $ surroundings ploc+    -- In "dirVisible", we store locations in the surroundings that are+    -- perceptible from the current position.+    dirVisible = S.filter (\ loc -> let p = perceptible (lmap `at` loc) :: [Dir]+                                    in  any (\ d -> shift loc d == ploc) p)+                          srnd+    ownVisible = S.union actVisible dirVisible+    -- Something is "pasVisible" if it is reachable passively visible from an+    -- "actVisible" location, *or* if it is in the surroundings and passively+    -- visible from a "dirVisible" location. (This is complicated, and I'd+    -- like to simplify it, but for now, it seems to at least do what I+    -- want.)+    pasVisible = S.filter (\ loc -> let p = passive (lmap `at` loc)+                                        dp = S.member loc srnd+                                        s = if dp then ownVisible else actVisible+                                    in  any (\ d -> S.member (shift loc d) s) p)+                          reachable+    visible = S.unions [pasVisible, actVisible, dirVisible]+    -- A simpler way to make walls of lit rooms visible, at the cost of making+    -- them reflect light from all sides, also from corridors.+    -- Can be hacked around by checking for corridors in the condition below.+    -- The version in the comment assumes player light has diameter 3, not 1,+    -- which looks a bit differently in dark rooms, revealing more walls.+    openSurroundings = S.filter (\ loc -> open (lmap `at` loc)) srnd+    openVisible = S.union actVisible openSurroundings+    simpleVisible =+      S.filter+        (\ loc -> S.member loc openVisible+                  || (reflects (lmap `at` loc)+                      && L.any+                           (\ l -> S.member l actVisible{-openVisible-})+                           (surroundings loc))+        ) (S.insert ploc reachable)+  in+    case fovMode of+      Shadow -> Perception reachable visible+      _      -> Perception reachable simpleVisible
+ src/Random.hs view
@@ -0,0 +1,74 @@+module Random (module Frequency, module Random) where++import Data.Ratio+import qualified System.Random as R+import Control.Monad.State++import Frequency++type Rnd a = State R.StdGen a++-- Written in a "portable" way because the implementation of+-- State changes between mtl versions 1 and 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)++-- | d for die/dice+d :: Int -> Rnd Int+d 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 xs) =+  do+    r <- randomR (1, sum (map fst xs))+    return (frequency' r xs)+ where+  frequency' :: Int -> [(Int, a)] -> a+  frequency' _ [(_, x)] = x+  frequency' m ((n, x) : xs)+    | m <= n            = x+    | otherwise         = frequency' (m - n) xs++rndToIO :: Rnd a -> IO a+rndToIO r =+  do+    g <- R.getStdGen+    let (x,g') = runState r g+    R.setStdGen g'+    return x++-- ** 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)
+ src/Save.hs view
@@ -0,0 +1,36 @@+module Save where++import System.Directory+import Control.Exception as E hiding (handle)++import File+import Level+import State+import qualified Config++-- | Name of the save game.+file :: Config.CP -> IO String+file config = Config.getFile config "LambdaHack.save" "files" "savegame"++-- | We save a simple serialized version of the current level and+-- the current state. The 'False' is used only as an EOF marker.+saveGame :: State -> IO ()+saveGame state =+  do+    f <- file (config state)+    encodeCompressedFile f (state,False)++-- | Restore a saved game. Returns either the current level and+-- 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+             f <- file config+             r <- strictDecodeCompressedFile f+             removeFile f+             case r of+               (x,z) -> (z :: Bool) `seq` return $ Left x)+          (\ e -> case e :: IOException of+                    _ -> return (Right $ "Restore failed: " +++                                 (unwords . lines) (show e)))
+ src/State.hs view
@@ -0,0 +1,133 @@+module State where++import qualified Data.Map as M+import qualified Data.Set as S+import Control.Monad+import Data.Binary+import qualified Config++import Monster+import Geometry+import Level+import Item+import Message++-- | 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      :: Player,+                 shistory     :: [Message],+                 ssensory     :: SensoryMode,+                 sdisplay     :: DisplayMode,+                 stime        :: Time,+                 sassocs      :: Assocs,       -- ^ how does every item appear+                 sdiscoveries :: Discoveries,  -- ^ items (types) have been discovered+                 sdungeon     :: Dungeon,      -- ^ all but current dungeon level+                 slevel       :: Level,+                 config       :: Config.CP+               }+  deriving Show++defaultState :: Loc -> Dungeon -> Level -> State+defaultState ploc dng lvl =+  State+    (defaultPlayer ploc)+    []+    Implicit Normal+    0+    M.empty+    S.empty+    dng+    lvl+    Config.empty_CP++updatePlayer :: (Monster -> Monster) -> State -> State+updatePlayer f s = s { splayer = f (splayer s) }++updateHistory :: ([String] -> [String]) -> State -> State+updateHistory f s = s { shistory = f (shistory s) }++updateDiscoveries :: (Discoveries -> Discoveries) -> State -> State+updateDiscoveries f s = s { sdiscoveries = f (sdiscoveries s) }++updateLevel :: (Level -> Level) -> State -> State+updateLevel f s = s { slevel = f (slevel s) }++updateTime :: (Time -> Time) -> State -> State+updateTime f s = s { stime = f (stime s) }++toggleVision :: State -> State+toggleVision s = s { ssensory = case ssensory s of Vision 1 -> Implicit; Vision n -> Vision (n-1); _ -> Vision 3 }++toggleSmell :: State -> State+toggleSmell s = s { ssensory = if ssensory s == Smell then Implicit else Smell }++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 hst sense disp time assocs discs dng lvl config) =+    do+      put player+      put hst+      put sense+      put disp+      put time+      put assocs+      put discs+      put dng+      put lvl+      put config+  get =+    do+      player <- get+      hst    <- get+      sense  <- get+      disp   <- get+      time   <- get+      assocs <- get+      discs  <- get+      dng    <- get+      lvl    <- get+      config <- get+      return (State player hst sense disp time assocs discs dng lvl config)++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 -> liftM Vision get+            2 -> return Smell+            _ -> fail "no parse (SensoryMode)"++data DisplayMode =+    Normal+  | Omniscient+  | Terrain Int+  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 -> liftM Terrain get+            _ -> fail "no parse (DisplayMode)"
+ src/Strategy.hs view
@@ -0,0 +1,49 @@+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 [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
+ src/StrategyState.hs view
@@ -0,0 +1,72 @@+module StrategyState where++import Data.List as L+import Data.Map as M+import Data.Set as S++import Geometry+import Level+import Monster+import Random+import Perception+import Strategy+import State++strategy :: Monster -> State -> Perception -> Strategy Dir+strategy m@(Monster { mtype = mt, mloc = me, mdir = mdir })+         (state@(State { splayer = player@(Monster { mloc = ploc }),+                         stime   = time,+                         slevel  = lvl@(Level { lmonsters = ms, lsmell = nsmap, lmap = lmap }) }))+         per =+    case mt of+      Eye     -> slowEye+      FastEye -> fastEye+      Nose    -> nose+      _       -> onlyAccessible moveRandomly+  where+    -- we check if the monster is visible by the player rather than if the+    -- player is visible by the monster -- this is more efficient, but+    -- won't be correct in the general situation+    playerVisible      =  me `S.member` pvisible per+    playerAdjacent     =  adjacent me ploc+    towardsPlayer      =  towards (me, ploc)+    onlyTowardsPlayer  =  only (\ x -> distance (towardsPlayer, x) <= 1)+    lootPresent        =  (\ x -> not $ L.null $ titems $ lmap `at` x)+    onlyLootPresent    =  onlyMoves lootPresent me+    onlyPreservesDir   =  only (\ x -> maybe True (\ d -> distance (neg d, x) > 1) mdir)+    onlyUnoccupied     =  onlyMoves (unoccupied ms lmap) me+    onlyAccessible     =  onlyMoves (accessible lmap me) me+    onlyOpenable       =  onlyMoves (openable 10 lmap) me+    smells             =  L.map fst $+                          L.sortBy (\ (_,s1) (_,s2) -> compare s2 s1) $+                          L.filter (\ (_,s) -> s > 0) $+                          L.map (\ x -> (x, nsmap ! (me `shift` x) - time `max` 0)) moves++    eye                =  onlyUnoccupied $+                            playerVisible .=> onlyTowardsPlayer moveRandomly+                            .| lootPresent me .=> return (0,0)+                            .| onlyLootPresent moveRandomly+                            .| onlyPreservesDir moveRandomly++    slowEye            =  playerAdjacent .=> return towardsPlayer+                          .| not playerVisible .=> onlyOpenable eye+                          .| onlyAccessible eye++    fastEye            =  playerAdjacent .=> return towardsPlayer+                          .| onlyAccessible eye++    nose               =  playerAdjacent .=> return towardsPlayer+                          .| (onlyAccessible $+                              lootPresent me .=> return (0,0)+                              .| foldr (.|) reject (L.map return smells)+                              .| onlyLootPresent moveRandomly+                              .| moveRandomly)++onlyMoves :: (Dir -> Bool) -> Loc -> Strategy Dir -> Strategy Dir+onlyMoves p l = only (\ x -> p (l `shift` x))++moveRandomly :: Strategy Dir+moveRandomly = liftFrequency $ uniform moves++wait :: Strategy Dir+wait = return (0,0)
+ src/Turn.hs view
@@ -0,0 +1,261 @@+module Turn where++import Control.Monad+import Control.Monad.State hiding (State)+import Data.Map as M++import Action+import Actions+import Actor+import Command+import Display2 hiding (display)+import Keybindings+import qualified Keys as K+import Level+import Monster+import Random+import State+import Strategy+import StrategyState+import Version++-- 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: check for hero's death, HP regeneration, determine who moves next,+--   dispatch to handleMonsters or handlePlayer+--+-- handlePlayer: remember, display, get and process commmand(s),+--   advance player time, update smell map, update perception+--+-- handleMonsters: find monsters that can move or die+--+-- handleMonster: determine and process monster action, advance monster time+--+-- nextMove: advance global game time, 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 = mtime (splayer state)  -- time of hero's next move+    let time  = stime state            -- current game time+    checkHeroDeath     -- hero can die even if it's not the hero's turn+    regenerate APlayer -- hero can regenerate even if it's not the hero's turn+    debug $ "handle: time check. ptime = " ++ show ptime ++ ", time = " ++ show time+    if ptime > time+      then do+             -- the hero can't make a move yet; monsters first+             -- we redraw the map even between player moves so that the movements of fast+             -- monsters can be traced on the map; we disable this functionality if the+             -- player is currently running, as it would slow down the running process+             -- unnecessarily+             ifRunning (const $ return True) display+             handleMonsters+      else do+             handlePlayer -- it's the hero's turn!++-- | 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.+handleMonsters :: Action ()+handleMonsters =+  do+    debug "handleMonsters"+    ms   <- gets (lmonsters . slevel)+    time <- gets stime+    case ms of+      [] -> nextMove+      (m@(Monster { mtime = mt }) : ms)+        | mt > time  -> -- no monster is ready for another move+                        nextMove+        | mhp m <= 0 -> -- the monster dies+                        do+                          modify (updateLevel (updateMonsters (const ms)))+                          -- place the monster's possessions on the map+                          modify (updateLevel (scatterItems (mitems m) (mloc m)))+                          handleMonsters+        | otherwise  -> -- monster m should move; we temporarily remove m from the level+                        -- TODO: removal isn't nice. Actor numbers currently change during+                        -- a move. This could be cleaned up.+                        do+                          modify (updateLevel (updateMonsters (const ms)))+                          handleMonster m++-- | Handle the move of a single monster.+-- Precondition: monster must not currently be in the monster list of the level.+handleMonster :: Monster -> Action ()+handleMonster m =+  do+    debug "handleMonster"+    state <- get+    let time = stime state+    let ms   = lmonsters (slevel state)+    per <- currentPerception+    -- run the AI; it currently returns a direction; TODO: it should return an action+    dir <- liftIO $ rndToIO $ frequency (head (runStrategy (strategy m state per .| wait)))+    let waiting    = dir == (0,0)+    let nmdir      = if waiting then Nothing else Just dir+    -- advance time and reinsert monster+    let nm         = m { mtime = time + mspeed m, mdir = nmdir }+    let (act, nms) = insertMonster nm ms+    modify (updateLevel (updateMonsters (const nms)))+    let actor      = AMonster act+    try $ -- if the following action aborts, we just continue+      if waiting+        then+          -- monster is not moving, let's try to pick up an object+          actorPickupItem actor+        else+          moveOrAttack True True actor dir+    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))+    generateMonster+    handle++-- | Handle the move of the hero.+handlePlayer :: Action ()+handlePlayer =+  do+    debug "handlePlayer"+    remember      -- the hero perceives his (potentially new) surroundings+    playerCommand -- get and process a player command+    -- at this point, the command was successful+    advanceTime APlayer     -- TODO: the command handlers should advance the move time+    state <- get+    let time = stime state+    let loc  = mloc (splayer state)+    -- update smell+    modify (updateLevel (updateSMap (M.insert loc (time + smellTimeout))))+    -- determine player perception and continue with monster moves+    withPerception handleMonsters++-- | Determine and process the next player command.+playerCommand :: Action ()+playerCommand =+  do+    display -- draw the current surroundings+    history -- update the message history and reset current message+    tryRepeatedlyWith stopRunning $ do -- on abort, just ask for a new command+      ifRunning continueRun $ do+        k <- session nextCommand+        handleKey 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 "display help"      displayHelp++-- | Display command help. TODO: Should be defined in Actions module.+displayHelp :: Action ()+displayHelp = messageOverlayConfirm "Basic keys:" helpString >> abort+  where+  helpString = keyHelp stdKeybindings++stdKeybindings :: Keybindings+stdKeybindings = Keybindings+  { kdir   = moveDirCommand,+    kudir  = runDirCommand,+    kother = M.fromList $+             [ -- interaction with the dungeon+               (K.Char 'o',  openCommand),+               (K.Char 'c',  closeCommand),+               (K.Char 's',  searchCommand),++               (K.Char '<',  ascendCommand),+               (K.Char '>',  descendCommand),++               (K.Char ':',  lookCommand),++               -- items+               (K.Char ',',  pickupCommand),+               (K.Char 'd',  dropCommand),+               (K.Char 'i',  inventoryCommand),+               (K.Char 'q',  drinkCommand),++               -- wait+               -- (K.Char ' ',  waitCommand),+               (K.Char '.',  waitCommand),++               -- saving or ending the game+               (K.Char 'S',  saveCommand),+               (K.Char 'Q',  quitCommand),+               (K.Esc     ,  Undescribed $ abortWith "Press Q to quit."),++               -- debug modes+               (K.Char 'V',  Undescribed $ modify toggleVision     >> withPerception playerCommand),+               (K.Char 'R',  Undescribed $ modify toggleSmell      >> playerCommand),+               (K.Char 'O',  Undescribed $ modify toggleOmniscient >> playerCommand),+               (K.Char 'T',  Undescribed $ modify toggleTerrain    >> playerCommand),+               (K.Char 'I',  Undescribed $ gets (lmeta . slevel) >>= abortWith),++               -- information for the player+               (K.Char 'v',  Undescribed $ abortWith version),+               (K.Char 'M',  historyCommand),+               (K.Char '?',  helpCommand),+               (K.Return  ,  helpCommand)+             ]+  }+
+ src/Version.hs view
@@ -0,0 +1,12 @@+module Version where++import Data.Version++-- Cabal+import qualified Paths_LambdaHack as Self (version)++import Display++version :: String+version = showVersion Self.version ++ " (" ++ displayId ++ " frontend)"+