diff --git a/Actor.hs b/Actor.hs deleted file mode 100644 --- a/Actor.hs +++ /dev/null @@ -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" - - diff --git a/COPYING b/COPYING deleted file mode 100644 --- a/COPYING +++ /dev/null @@ -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. - - - Copyright (C) - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 51 Franklin 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. - - , 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. diff --git a/CREDITS b/CREDITS new file mode 100644 --- /dev/null +++ b/CREDITS @@ -0,0 +1,4 @@ +Developers who have contributed significantly to LambdaHack: + +Andres Loeh +Mikolaj Konarski diff --git a/DESIGN.markdown b/DESIGN.markdown new file mode 100644 --- /dev/null +++ b/DESIGN.markdown @@ -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. diff --git a/Display.hs b/Display.hs deleted file mode 100644 --- a/Display.hs +++ /dev/null @@ -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 - diff --git a/Display/Curses.hs b/Display/Curses.hs deleted file mode 100644 --- a/Display/Curses.hs +++ /dev/null @@ -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) diff --git a/Display/Gtk.hs b/Display/Gtk.hs deleted file mode 100644 --- a/Display/Gtk.hs +++ /dev/null @@ -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) diff --git a/Display/Vty.hs b/Display/Vty.hs deleted file mode 100644 --- a/Display/Vty.hs +++ /dev/null @@ -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 diff --git a/Display2.hs b/Display2.hs deleted file mode 100644 --- a/Display2.hs +++ /dev/null @@ -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 - - diff --git a/Dungeon.hs b/Dungeon.hs deleted file mode 100644 --- a/Dungeon.hs +++ /dev/null @@ -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 - diff --git a/FOV.hs b/FOV.hs deleted file mode 100644 --- a/FOV.hs +++ /dev/null @@ -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)) - diff --git a/File.hs b/File.hs deleted file mode 100644 --- a/File.hs +++ /dev/null @@ -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 - diff --git a/Frequency.hs b/Frequency.hs deleted file mode 100644 --- a/Frequency.hs +++ /dev/null @@ -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)) diff --git a/Geometry.hs b/Geometry.hs deleted file mode 100644 --- a/Geometry.hs +++ /dev/null @@ -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] diff --git a/Item.hs b/Item.hs deleted file mode 100644 --- a/Item.hs +++ /dev/null @@ -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 " ++) diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/LambdaHack.cabal b/LambdaHack.cabal --- a/LambdaHack.cabal +++ b/LambdaHack.cabal @@ -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 maintainer: Andres Loeh 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 } } diff --git a/LambdaHack.config.example b/LambdaHack.config.example new file mode 100644 --- /dev/null +++ b/LambdaHack.config.example @@ -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 diff --git a/LambdaHack.hs b/LambdaHack.hs deleted file mode 100644 --- a/LambdaHack.hs +++ /dev/null @@ -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 - diff --git a/Level.hs b/Level.hs deleted file mode 100644 --- a/Level.hs +++ /dev/null @@ -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) - diff --git a/Message.hs b/Message.hs deleted file mode 100644 --- a/Message.hs +++ /dev/null @@ -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 - diff --git a/Monster.hs b/Monster.hs deleted file mode 100644 --- a/Monster.hs +++ /dev/null @@ -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) diff --git a/PLAYING.markdown b/PLAYING.markdown new file mode 100644 --- /dev/null +++ b/PLAYING.markdown @@ -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! diff --git a/Perception.hs b/Perception.hs deleted file mode 100644 --- a/Perception.hs +++ /dev/null @@ -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 - diff --git a/README b/README deleted file mode 100644 --- a/README +++ /dev/null @@ -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. diff --git a/README.markdown b/README.markdown new file mode 100644 --- /dev/null +++ b/README.markdown @@ -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 diff --git a/Random.hs b/Random.hs deleted file mode 100644 --- a/Random.hs +++ /dev/null @@ -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) diff --git a/Save.hs b/Save.hs deleted file mode 100644 --- a/Save.hs +++ /dev/null @@ -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))) - diff --git a/State.hs b/State.hs deleted file mode 100644 --- a/State.hs +++ /dev/null @@ -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)" - diff --git a/Strategy.hs b/Strategy.hs deleted file mode 100644 --- a/Strategy.hs +++ /dev/null @@ -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 diff --git a/Style.hs b/Style.hs deleted file mode 100644 --- a/Style.hs +++ /dev/null @@ -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 diff --git a/Turn.hs b/Turn.hs deleted file mode 100644 --- a/Turn.hs +++ /dev/null @@ -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 - - diff --git a/Version.hs b/Version.hs deleted file mode 100644 --- a/Version.hs +++ /dev/null @@ -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)" - diff --git a/src/Action.hs b/src/Action.hs new file mode 100644 --- /dev/null +++ b/src/Action.hs @@ -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) + diff --git a/src/Actions.hs b/src/Actions.hs new file mode 100644 --- /dev/null +++ b/src/Actions.hs @@ -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) }) + diff --git a/src/Actor.hs b/src/Actor.hs new file mode 100644 --- /dev/null +++ b/src/Actor.hs @@ -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" diff --git a/src/Command.hs b/src/Command.hs new file mode 100644 --- /dev/null +++ b/src/Command.hs @@ -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 + diff --git a/src/Config.hs b/src/Config.hs new file mode 100644 --- /dev/null +++ b/src/Config.hs @@ -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 diff --git a/src/Display.hs b/src/Display.hs new file mode 100644 --- /dev/null +++ b/src/Display.hs @@ -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 + diff --git a/src/Display/Curses.hs b/src/Display/Curses.hs new file mode 100644 --- /dev/null +++ b/src/Display/Curses.hs @@ -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) diff --git a/src/Display/Gtk.hs b/src/Display/Gtk.hs new file mode 100644 --- /dev/null +++ b/src/Display/Gtk.hs @@ -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) diff --git a/src/Display/Vty.hs b/src/Display/Vty.hs new file mode 100644 --- /dev/null +++ b/src/Display/Vty.hs @@ -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 diff --git a/src/Display2.hs b/src/Display2.hs new file mode 100644 --- /dev/null +++ b/src/Display2.hs @@ -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 diff --git a/src/Dungeon.hs b/src/Dungeon.hs new file mode 100644 --- /dev/null +++ b/src/Dungeon.hs @@ -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 diff --git a/src/FOV.hs b/src/FOV.hs new file mode 100644 --- /dev/null +++ b/src/FOV.hs @@ -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) diff --git a/src/File.hs b/src/File.hs new file mode 100644 --- /dev/null +++ b/src/File.hs @@ -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 + diff --git a/src/Frequency.hs b/src/Frequency.hs new file mode 100644 --- /dev/null +++ b/src/Frequency.hs @@ -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)) diff --git a/src/Geometry.hs b/src/Geometry.hs new file mode 100644 --- /dev/null +++ b/src/Geometry.hs @@ -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] diff --git a/src/Grammar.hs b/src/Grammar.hs new file mode 100644 --- /dev/null +++ b/src/Grammar.hs @@ -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 ++ "." diff --git a/src/HighScores.hs b/src/HighScores.hs new file mode 100644 --- /dev/null +++ b/src/HighScores.hs @@ -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) diff --git a/src/Item.hs b/src/Item.hs new file mode 100644 --- /dev/null +++ b/src/Item.hs @@ -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") diff --git a/src/ItemState.hs b/src/ItemState.hs new file mode 100644 --- /dev/null +++ b/src/ItemState.hs @@ -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 " ++) diff --git a/src/Keybindings.hs b/src/Keybindings.hs new file mode 100644 --- /dev/null +++ b/src/Keybindings.hs @@ -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]) + diff --git a/src/Keys.hs b/src/Keys.hs new file mode 100644 --- /dev/null +++ b/src/Keys.hs @@ -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 = "" +showKey Return = "" +showKey PgUp = "" +showKey PgDn = "" +showKey Left = "" +showKey Right = "" +showKey Up = "" +showKey Down = "" +showKey End = "" +showKey Home = "" diff --git a/src/LambdaHack.hs b/src/LambdaHack.hs new file mode 100644 --- /dev/null +++ b/src/LambdaHack.hs @@ -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 diff --git a/src/Level.hs b/src/Level.hs new file mode 100644 --- /dev/null +++ b/src/Level.hs @@ -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 diff --git a/src/LevelState.hs b/src/LevelState.hs new file mode 100644 --- /dev/null +++ b/src/LevelState.hs @@ -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 "." diff --git a/src/Message.hs b/src/Message.hs new file mode 100644 --- /dev/null +++ b/src/Message.hs @@ -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 diff --git a/src/Monster.hs b/src/Monster.hs new file mode 100644 --- /dev/null +++ b/src/Monster.hs @@ -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) diff --git a/src/Perception.hs b/src/Perception.hs new file mode 100644 --- /dev/null +++ b/src/Perception.hs @@ -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 diff --git a/src/Random.hs b/src/Random.hs new file mode 100644 --- /dev/null +++ b/src/Random.hs @@ -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) diff --git a/src/Save.hs b/src/Save.hs new file mode 100644 --- /dev/null +++ b/src/Save.hs @@ -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))) diff --git a/src/State.hs b/src/State.hs new file mode 100644 --- /dev/null +++ b/src/State.hs @@ -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)" diff --git a/src/Strategy.hs b/src/Strategy.hs new file mode 100644 --- /dev/null +++ b/src/Strategy.hs @@ -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 diff --git a/src/StrategyState.hs b/src/StrategyState.hs new file mode 100644 --- /dev/null +++ b/src/StrategyState.hs @@ -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) diff --git a/src/Turn.hs b/src/Turn.hs new file mode 100644 --- /dev/null +++ b/src/Turn.hs @@ -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) + ] + } + diff --git a/src/Version.hs b/src/Version.hs new file mode 100644 --- /dev/null +++ b/src/Version.hs @@ -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)" +