LambdaHack 0.1.20080413 → 0.1.20090606
raw patch · 20 files changed
+972/−326 lines, 20 filesdep ~basedep ~binarydep ~bytestring
Dependency ranges changed: base, binary, bytestring, containers, directory, gtk, hscurses, mtl, random, zlib
Files
- Display/Curses.hs +6/−3
- Display/Gtk.hs +13/−12
- Display/Vty.hs +6/−7
- Display2.hs +60/−21
- Dungeon.hs +101/−61
- FOV.hs +9/−9
- File.hs +2/−2
- Frequency.hs +1/−1
- Geometry.hs +18/−0
- Item.hs +181/−45
- LambdaHack.cabal +6/−6
- LambdaHack.hs +9/−2
- Level.hs +191/−91
- Perception.hs +23/−8
- README +9/−3
- Random.hs +16/−1
- Save.hs +12/−2
- State.hs +36/−7
- Strategy.hs +1/−1
- Turn.hs +272/−44
Display/Curses.hs view
@@ -1,9 +1,9 @@ module Display.Curses (displayId, startup, shutdown,- display, nextEvent, setBG, setFG, Session,+ display, nextEvent, setBG, setFG, setBold, Session, white, black, yellow, blue, magenta, red, green, attr, Display.Curses.Attr) where -import UI.HSCurses.Curses as C+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@@ -68,6 +68,8 @@ 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"@@ -108,5 +110,6 @@ red = Red green = Green +setBold (f, b) = (f, b) setFG c (_, b) = (Just c, b)-setBG c (f, b) = (f, Just c)+setBG c (f, _) = (f, Just c)
Display/Gtk.hs view
@@ -1,6 +1,6 @@ module Display.Gtk (displayId, startup, shutdown, - display, nextEvent, setBG, setFG, Session,+ display, nextEvent, setBG, setFG, setBold, Session, white, black, yellow, blue, magenta, red, green, attr, Attr) where import Control.Monad@@ -125,18 +125,19 @@ mapM_ (\ c -> textBufferApplyTag tb (tts ! c) ib ie) a nextEvent :: Session -> IO String-nextEvent session = readChan (schan session)+nextEvent = readChan . schan -setBG c = (BG c :)-setFG c = (FG c :)-blue = Blue-magenta = Magenta-red = Red-yellow = Yellow-green = Green-white = White-black = Black-attr = []+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]
Display/Vty.hs view
@@ -1,6 +1,6 @@ module Display.Vty (displayId, startup, shutdown,- display, nextEvent, setBG, setFG, Session,+ display, nextEvent, setBold, setBG, setFG, Session, white, black, yellow, blue, magenta, red, green, attr, Attr) where import Graphics.Vty as V@@ -15,10 +15,7 @@ type Session = V.Vty startup :: (Session -> IO ()) -> IO ()-startup k =- do- session <- V.mkVty- k session+startup k = V.mkVty >>= k display :: Area -> Session -> (Loc -> (Attr, Char)) -> String -> String -> IO () display ((y0,x0),(y1,x1)) vty f msg status =@@ -27,9 +24,9 @@ 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)))) <->+ (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))))))+ renderBS attr (BS.pack (L.map (fromIntegral . ord) (toWidth (x1 - x0 + 1) status))))) toWidth :: Int -> String -> String toWidth n x = take n (x ++ repeat ' ')@@ -45,6 +42,8 @@ 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"
Display2.hs view
@@ -11,9 +11,10 @@ import Level import Perception import Monster+import Item -- | Displays a message on a blank screen. Waits for confirmation.-displayBlankConfirm :: Session -> String -> IO ()+displayBlankConfirm :: Session -> String -> IO Bool displayBlankConfirm session txt = let x = txt ++ more in do@@ -21,19 +22,24 @@ getConfirm session -- | Waits for a space or return.-getConfirm :: Session -> IO ()+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 (getConfirm session) $+ handleModifier e (getOptionalConfirm session h k) $ case e of- "space" -> return ()- "Return" -> return ()- _ -> getConfirm session + "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 () -> IO () -> IO ()+handleModifier :: String -> IO a -> IO a -> IO a handleModifier e h k = case e of "Shift_R" -> h@@ -63,12 +69,35 @@ "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@(Level nm sz ms smap nlmap lmeta))+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 }))- msg =+ (state@(State { splayer = player@(Monster { mhp = php, mdir = pdir, mloc = ploc }), stime = time, sassocs = assocs }))+ msg overlay = let reachable = preachable per visible = pvisible per@@ -83,28 +112,38 @@ else if rea then setBG magenta else id else \ vis rea -> id- disp msg = + (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 (tterrain tile)+ _ | sTer > 0 -> viewTerrain sTer False (tterrain tile) Just m | sOmn || vis -> viewMonster (mtype m) _ | sSml && sml >= 0 -> viewSmell sml- | otherwise -> viewTile tile+ | otherwise -> viewTile vis tile assocs vision = lVision vis rea in- (ra . vision $- attr, rv))+ 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 ("HP: " ++ show php ++ repeat ' ') +++ (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 (snd sz) msg- perf [] = disp ""- perf [xs] = disp xs- perf (x:xs) = disp (x ++ more) >> getConfirm session >> perf xs- in perf msgs+ msgs = splitMsg sx msg+ perf k [] = perfo k ""+ perf k [xs] = perfo k xs+ perf k (x:xs) = disp n (x ++ more) >> getConfirm session >>= \ b ->+ if b then perf k xs else return False+ perfo k xs+ | k < n - 1 = disp k xs >> getConfirm session >>= \ b ->+ if b then perfo (k+1) xs else return False+ | otherwise = disp k xs >> return True+ in perf 0 msgs
Dungeon.hs view
@@ -1,5 +1,6 @@ module Dungeon where +import Prelude hiding (floor) import Control.Monad import Data.Map as M@@ -22,10 +23,18 @@ 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))+ (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@@ -61,7 +70,7 @@ 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 is,u) = (Tile Floor is,u)+ corridorUpdate _ (Tile (Floor l) is,u) = (Tile (Floor l) is,u) corridorUpdate (x,u) _ = (x,u) digCorridor _ l = l @@ -72,69 +81,94 @@ LevelName -> Rnd (Maybe (Maybe DungeonLoc) -> Maybe (Maybe DungeonLoc) -> Level, Loc, Loc) bigroom (LevelConfig { levelSize = (sy,sx) }) nm = do- let lmap = digRoom ((1,1),(sy-1,sx-1)) (emptyLMap (sy,sx))+ 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) . tterrain))- sd <- findLoc lvl (\ l t -> tterrain t == Floor && distance (su,l) > 676)- return $ (\ lu ld ->- let flmap = maybe id (\ l -> M.insert su (newTile (Stairs Up l))) lu $- maybe id (\ l -> M.insert sd (newTile (Stairs Down l))) ld $+ 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 :: (Y,X),- minRoomSize :: (Y,X),- border :: Int, -- must be at least 2!- levelSize :: (Y,X), -- lower right point- extraConnects :: Int,- minStairsDistance :: Int, -- must not be too large- doorChance :: Rational,- doorOpenChance :: Rational,- doorSecretChance :: Rational,+ 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 :: (Int,Int)+ nrItems :: Rnd Int, -- range+ depth :: Int -- general indicator of difficulty } -defaultLevelConfig :: LevelConfig-defaultLevelConfig =+defaultLevelConfig :: Int -> LevelConfig+defaultLevelConfig d = LevelConfig {- levelGrid = (3,3), -- (7,10), -- (3,3), -- (2,5)- minRoomSize = (2,2),+ 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), -- (77,231), -- (22,79),- extraConnects = 3, -- 6+ levelSize = (22,79),+ extraConnects = \ (y,x) -> (y*x) `div` 3, + noRooms = \ (y,x) -> randomR (0,(y*x) `div` 3), minStairsDistance = 676,- doorChance = 1%2,- doorOpenChance = 1%2,- doorSecretChance = 1%3,+ doorChance = chance $ 1%2,+ doorOpenChance = chance $ 1%2,+ doorSecretChance = chance $ 1%3, doorSecretMax = 15,- nrItems = (3,7) -- range+ nrItems = randomR (3,7),+ depth = d } -largeLevelConfig :: LevelConfig-largeLevelConfig =- defaultLevelConfig {- levelGrid = (7,10),+largeLevelConfig :: Int -> LevelConfig+largeLevelConfig d =+ (defaultLevelConfig d) {+ levelGrid = return (7,10), levelSize = (77,231),- extraConnects = 10+ extraConnects = const 10 } level :: LevelConfig -> LevelName -> Rnd (Maybe (Maybe DungeonLoc) -> Maybe (Maybe DungeonLoc) -> Level, Loc, Loc) level cfg nm = do- let gs = M.toList (grid (levelGrid cfg) ((0,0),levelSize cfg))+ 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' <- mkRoom (border cfg) (minRoomSize cfg) r+ r' <- if i `elem` nr+ then mkNoRoom (border cfg) r+ else mkRoom (border cfg) lminroom r return (i,r')) gs- let rooms = L.map snd rs0+ 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 (levelGrid cfg)- addedConnects <- replicateM (extraConnects cfg) (randomConnection (levelGrid cfg))+ connects <- connectGrid lgrid+ addedConnects <- replicateM (extraConnects cfg lgrid) (randomConnection lgrid) let allConnects = L.nub (addedConnects ++ connects) cs <- mapM (\ (p0,p1) -> do@@ -144,7 +178,8 @@ 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 digRoom (emptyLMap (levelSize cfg)) rooms) cs+ 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@@ -153,12 +188,12 @@ Tile (Opening hv) _ -> do -- chance for doors- rb <- chance (doorChance cfg)+ rb <- doorChance cfg -- chance for a door to be open- ro <- chance (doorOpenChance cfg)+ ro <- doorOpenChance cfg rs <- if ro then return Nothing else do -- chance for a door to be secret- rsc <- chance (doorSecretChance cfg)+ rsc <- doorSecretChance cfg fmap Just (if rsc then randomR (1, doorSecretMax cfg) else return 0)@@ -168,44 +203,49 @@ _ -> return o) . M.toList $ lmap -- determine number of items, items and locations for the items- nri <- randomR (nrItems cfg)+ nri <- nrItems cfg is <- replicateM nri $ do- l <- findLoc lvl (const ((==Floor) . tterrain))- t <- newItem itemFrequency + l <- findLoc lvl (const floor)+ t <- newItem (depth cfg) itemFrequency return (l,t) -- locations of the stairs- su <- findLoc lvl (const ((==Floor) . tterrain))- sd <- findLoc lvl (\ l t -> tterrain t == Floor && distance (su,l) > minStairsDistance cfg)+ 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.insert su (newTile (Stairs Up l))) lu $- maybe id (\ l -> M.insert sd (newTile (Stairs Down l))) ld $- foldr (\ (l,it) f -> M.update (\ (t,r) -> Just (t { titems = it : titems t }, r)) l . f) id is $+ 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] ] -digRoom :: Room -> LMap -> LMap-digRoom ((y0,x0),(y1,x1)) l =- let rm = M.fromList $ [ ((y,x),newTile Floor) | x <- [x0..x1], y <- [y0..y1] ]- ++ [ ((y,x),newTile (Wall Horiz)) | x <- [x0-1..x1+1], y <- [y0-1,y1+1] ]- ++ [ ((y,x),newTile (Wall Vert)) | x <- [x0-1,x1+1], y <- [y0..y1] ]+-- | 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- -- TODO: remove the hardcoded chance- rc <- chance (1 % if L.null ms then 50 else 700)+ rc <- monsterGenChance (lname lvl) ms if rc then do- -- TODO: new monsters always be generated in a place that isn't+ -- 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 -> tterrain t == Floor && + sm <- findLoc lvl (\ l t -> floor t && not (l `L.elem` L.map mloc (player : ms)) && distance (ploc, l) > 400) m <- newMonster sm monsterFrequency
FOV.hs view
@@ -20,7 +20,7 @@ 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+ 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)) $@@ -47,14 +47,14 @@ | 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)+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 $
File.hs view
@@ -14,9 +14,9 @@ LBS.length d `seq` return d strictDecodeCompressedFile :: Binary a => FilePath -> IO a-strictDecodeCompressedFile f = fmap decode (strictReadCompressedFile f)+strictDecodeCompressedFile = fmap decode . strictReadCompressedFile encodeCompressedFile :: Binary a => FilePath -> a -> IO ()-encodeCompressedFile f x = LBS.writeFile f (Z.compress (encode x))+encodeCompressedFile f = LBS.writeFile f . Z.compress . encode -- note that LBS.writeFile opens the file in binary mode
Frequency.hs view
@@ -28,4 +28,4 @@ scale n (Frequency xs) = Frequency (map (\ (p, x) -> (n * p, x)) xs) uniform :: [a] -> Frequency a-uniform xs = Frequency (map (\ x -> (1, x)) xs)+uniform = Frequency . map (\ x -> (1, x))
Geometry.hs view
@@ -29,6 +29,9 @@ 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 @@ -40,3 +43,18 @@ moves :: [Dir] moves = [ (x,y) | x <- [-1..1], y <- [-1..1], x /= 0 || y /= 0 ]++up, down, left, right :: Dir+upleft, upright, downleft, downright :: Dir+upleft = up `shift` left+upright = up `shift` right+downleft = down `shift` left+downright = down `shift` right+up = (-1,0)+down = (1,0)+left = (0,-1)+right = (0,1)++horiz, vert :: [Dir]+horiz = [left, right]+vert = [up, down]
Item.hs view
@@ -1,9 +1,11 @@ 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@@ -11,88 +13,222 @@ import Random data Item = Item- { itype :: ItemType, + { icount :: Int,+ itype :: ItemType, iletter :: Maybe Char } -- inventory identifier deriving Show data ItemType = Ring | Scroll- | Potion+ | Potion PotionType | Wand | Amulet | Gem | Gold- deriving Show+ 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 itype iletter) = put itype >> put iletter- get = liftM2 Item get get+ 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 = putWord8 2- put Wand = putWord8 3- put Amulet = putWord8 4- put Gem = putWord8 5- put Gold = putWord8 6+ 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 -> return Potion+ 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 [- (10, Gold),- (3, Gem),- (2, Ring),- (4, Scroll),- (2, Wand),- (1, Amulet),- (4, Potion)+ (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 :: Frequency ItemType -> Rnd Item-newItem ftp =+newItem :: Int -> Frequency ItemType -> Rnd Item+newItem n ftp = do tp <- frequency ftp- return (Item tp Nothing)+ 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 starting--- letter.-assignLetter :: Char -> [Item] -> Maybe Char-assignLetter c is =- listToMaybe (L.filter (\x -> not (x `member` current)) candidates)+-- 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 (findIndex (==c) allLetters)) (cycle allLetters))+ candidates = take (length allLetters) (drop (fromJust (L.findIndex (==c) allLetters)) (cycle allLetters))+ free = L.filter (\x -> not (x `S.member` current)) candidates+ allowed = '$' : free -viewItem :: ItemType -> (Char, Attr -> Attr)-viewItem Ring = ('=', id)-viewItem Scroll = ('?', id)-viewItem Potion = ('!', id)-viewItem Wand = ('/', id)-viewItem Gold = ('$', setFG yellow)-viewItem Gem = ('*', setFG red)-viewItem _ = ('~', id)+cmpLetter :: Char -> Char -> Ordering+cmpLetter x y = compare (isUpper x, toLower x) (isUpper y, toLower y) -objectItem :: ItemType -> String-objectItem Ring = "a ring"-objectItem Scroll = "a scroll"-objectItem Potion = "a potion"-objectItem Wand = "a wand"-objectItem Amulet = "an amulet"-objectItem Gem = "a gem"-objectItem Gold = "some gold"+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 " ++)
LambdaHack.cabal view
@@ -1,6 +1,6 @@ cabal-version: >= 1.2 name: LambdaHack-version: 0.1.20080413+version: 0.1.20090606 license: GPL license-file: COPYING data-files: README@@ -26,18 +26,18 @@ Level, Message, Monster, Perception, Random, Save, Setup, State, Strategy, Style, Turn, Version- build-depends: base >= 3, containers >= 0.1, binary >= 0.4,- random >= 1, zlib >= 0.4, bytestring >= 0.9,- directory >= 1, mtl >= 1.1+ 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 if flag(curses) { other-modules: Display.Curses- build-depends: hscurses >= 1.3+ build-depends: hscurses >= 1.3 && < 2 cpp-options: -DCURSES extra-libraries: curses } else { if flag(gtk) { other-modules: Display.Gtk- build-depends: gtk >= 0.9.12+ build-depends: gtk >= 0.9.12 && < 0.11 cpp-options: -DGTK } else { other-modules: Display.Vty
LambdaHack.hs view
@@ -2,6 +2,7 @@ import System.Directory import Control.Monad+import Data.Map as M import State import Geometry@@ -12,6 +13,7 @@ import Random import Save import Turn+import Item main :: IO () main = startup start@@ -37,7 +39,7 @@ do -- generate dungeon with 10 levels levels <- rndToIO $- mapM (\n -> (if n == 3 then bigroom else level) defaultLevelConfig $+ 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)] ->@@ -49,6 +51,11 @@ in x' : z : zs let lvls = connect (Just Nothing) levels let (lvl,dng) = (head lvls, dungeon (tail lvls))- let state = defaultState ((\ (_,x,_) -> x) (head levels)) dng+ -- generate item associations+ let assocs = M.fromList+ [ (Potion PotionWater, Clear),+ (Potion PotionHealing, White) ]+ let state = (defaultState ((\ (_,x,_) -> x) (head levels)) dng)+ { sassocs = assocs } handle session lvl state (perception_ state lvl) msg
Level.hs view
@@ -21,6 +21,16 @@ 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@@ -108,37 +118,85 @@ unknown = Tile Unknown [] data Terrain = Rock- | Opening HV- | Floor+ | Opening Pos+ | Floor DL | Unknown | Corridor- | Wall HV- | Stairs VDir (Maybe DungeonLoc)- | Door HV (Maybe Int) -- Nothing: open, Just 0: closed, otherwise secret+ | 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 d) = putWord8 1 >> put d- put Floor = putWord8 2- put Unknown = putWord8 3- put Corridor = putWord8 4- put (Wall d) = putWord8 5 >> put d- put (Stairs d n) = putWord8 6 >> put d >> put n- put (Door d o) = putWord8 7 >> put d >> put o+ 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 -> return Floor+ 2 -> liftM Floor get 3 -> return Unknown 4 -> return Corridor 5 -> liftM Wall get- 6 -> liftM2 Stairs get 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) @@ -158,6 +216,11 @@ 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) @@ -169,18 +232,22 @@ instance Eq Terrain where Rock == Rock = True Opening d == Opening d' = d == d'- Floor == Floor = True+ Floor l == Floor l' = l == l' Unknown == Unknown = True Corridor == Corridor = True- Wall d == Wall d' = d == d'- Stairs d _ == Stairs d' _ = d == d'- Door d o == Door d' o' = d == d' && o == o'+ 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@@ -189,35 +256,63 @@ 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+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 _) = True-light (Tile (Opening _) _) = True-light (Tile (Door _ Nothing) _) = True -- open doors are all visible currently-light (Tile (Stairs _ _) _) = True-light (Tile (Wall _) _) = False+light (Tile (Floor l) _) = fromDL l+light (Tile (Stairs l _ _) _) = fromDL l light _ = False --- | reflects light from adjacent positions;--- exclusively passive: cannot be seen from an adjacent position in darkness-passive :: Tile -> (Bool,[(Y,X)]) -- exclusively passive?-passive (Tile (Wall Horiz) _) = (True, vert ++ [(-1,1),(1,1),(-1,-1),(1,-1)]) -- for corners-passive (Tile (Wall Vert) _) = (True, horiz)-passive (Tile (Door Horiz (Just 0)) _) = (False, vert)-passive (Tile (Door Vert (Just 0)) _) = (False, horiz)-passive (Tile (Door Horiz (Just n)) _) = (True, vert)-passive (Tile (Door Vert (Just n)) _) = (True, horiz)-passive _ = (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@@ -236,13 +331,10 @@ in open tgt && (not (diagonal dir) || case (tterrain src, tterrain tgt) of- (Door _ _, _) -> False- (_, Door _ _) -> False+ (Door {}, _) -> False+ (_, Door {}) -> False _ -> True) -horiz = [(0,-1),(0,1)]-vert = [(-1,0),(1,0)]- findLocInArea :: Area -> (Loc -> Bool) -> Rnd Loc findLocInArea a@((y0,x0),(y1,x1)) p = do@@ -338,33 +430,40 @@ | x0 <= x1 = [x0..x1] | otherwise = [x0,x0-1..x1] -viewTile :: Tile -> (Char, Attr -> Attr)-viewTile (Tile t []) = viewTerrain 0 t-viewTile (Tile t (i:_)) = viewItem (itype i)+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 ...-lookAt :: Bool -> LMap -> Loc -> String-lookAt detailed lvl loc- | L.null is && detailed = lookTerrain (tterrain (lvl `at` loc))- | otherwise = isd+--+-- 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 = unwords $ L.map (objectItem . itype) $ is-+ 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 = "empty floor"-lookTerrain Corridor = "empty corridor"-lookTerrain (Opening _) = "an opening"-lookTerrain (Stairs Up _) = "staircase up"-lookTerrain (Stairs Down _) = "staircase down"-lookTerrain (Door _ Nothing) = "an open door"-lookTerrain _ = ""+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: --@@ -373,36 +472,37 @@ -- 2: doors added -- 3: corridors and openings added -- 4: only rooms-viewTerrain :: Int -> Terrain -> (Char, Attr -> Attr)-viewTerrain n Rock = (' ', id)-viewTerrain n (Opening d)- | n <= 3 = ('.', id)- | otherwise = viewTerrain 0 (Wall d)-viewTerrain n Floor = ('.', id)-viewTerrain n Unknown = (' ', id)-viewTerrain n Corridor- | n <= 3 = ('#', id)- | otherwise = viewTerrain 0 Rock-viewTerrain n (Wall Horiz) = ('-', id)-viewTerrain n (Wall Vert) = ('|', id)-viewTerrain n (Stairs Up _)- | n <= 1 = ('<', id)- | otherwise = viewTerrain 0 Floor-viewTerrain n (Stairs Down _)- | n <= 1 = ('>', id)- | otherwise = viewTerrain 0 Floor-viewTerrain n (Door d (Just 0))- | n <= 2 = ('+', setFG yellow)- | otherwise = viewTerrain n (Opening d)-viewTerrain n (Door d (Just _))- | n <= 2 = viewTerrain n (Wall d) -- secret door- | otherwise = viewTerrain n (Opening d)-viewTerrain n (Door Horiz Nothing)- | n <= 2 = ('|', setFG yellow)- | otherwise = viewTerrain n (Opening Horiz)-viewTerrain n (Door Vert Nothing)- | n <= 2 = ('-', setFG yellow)- | otherwise = viewTerrain n (Opening Vert)+--+-- 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 = '*'
Perception.hs view
@@ -18,16 +18,31 @@ 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- actVisible = S.filter (\ loc -> light (lmap `at` loc)) reachable- pasVisible = S.filter (\ loc -> let (x,p) = passive (lmap `at` loc)- in any (\ d -> S.member (shift loc d) actVisible) p ||- (not x && adjacent loc ploc))- -- the above "not x" prevents walls from- -- being visible from the outside when- -- adjacent+ -- 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.union pasVisible actVisible+ visible = S.unions [pasVisible, actVisible, dirVisible] in Perception reachable visible
README view
@@ -1,6 +1,12 @@ Installation via Cabal. -There are two displays to choose from. One based on vty,-one based on gtk2hs. The gtk2hs variant is the default.-To get the other, pass -f-gtk to Setup configure.+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.
Random.hs view
@@ -9,7 +9,7 @@ type Rnd a = State R.StdGen a randomR :: (R.Random a) => (a, a) -> Rnd a-randomR r = State (R.randomR r)+randomR = State . R.randomR binaryChoice :: a -> a -> Rnd a binaryChoice p0 p1 =@@ -25,6 +25,10 @@ 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@@ -50,3 +54,14 @@ let (x,g') = runState r g R.setStdGen g' return x++-- ** Arithmetic operations on Rnd.++infixl 7 *~+infixl 6 ~+~++(~+~) :: Num a => Rnd a -> Rnd a -> Rnd a+(~+~) = liftM2 (+)++(*~) :: Num a => Int -> Rnd a -> Rnd a+x *~ r = liftM sum (replicateM x r)
Save.hs view
@@ -7,8 +7,20 @@ 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@@ -20,5 +32,3 @@ _ -> return (Right $ "Restore failed: " ++ (unwords . lines) (show e))) -saveGame :: Level -> State -> IO ()-saveGame lvl state = encodeCompressedFile savefile (lvl,state,False)
State.hs view
@@ -1,32 +1,48 @@ 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,- ssensory :: SensoryMode,- sdisplay :: DisplayMode,- stime :: Time,- sdungeon :: Dungeon+ { 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 } @@ -40,14 +56,27 @@ 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 sense disp time dng) =+ 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 = liftM5 State get get get get get+ 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
Strategy.hs view
@@ -14,7 +14,7 @@ instance Monad Strategy where return x = Strategy $ return (Frequency [(1, x)]) m >>= f = Strategy $- filter (\ (Frequency xs) -> not (null xs)) $+ filter (\ (Frequency xs) -> not (null xs)) [ Frequency [ (p * q, b) | (p, a) <- runFrequency x, y <- runStrategy (f a),
Turn.hs view
@@ -4,6 +4,8 @@ import Data.Map as M import Data.Set as S import Data.Char+import Data.Maybe+import Data.Function import State import Geometry@@ -85,7 +87,7 @@ handleMonsters session nlvl (updatePlayer state (const np)) per (addMsg oldmsg msg)) (handleMonsters session nlvl state per oldmsg)- nlvl player per+ nlvl player (sassocs state) (sdiscoveries state) per (AMonster act) nl @@ -137,9 +139,8 @@ -- | 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 }))+ (state@(State { splayer = player@(Monster { mhp = php, mdir = pdir, mloc = ploc, mitems = pinv, mtime = ptime }), stime = time, sassocs = assocs, sdiscoveries = discs })) per oldmsg =- do -- check for player death if php <= 0 then do@@ -147,14 +148,18 @@ getConfirm session shutdown session else -- check if the player can make another move yet- if ptime > time then handleMonsters session lvl state per oldmsg + 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 = do- e <- nextEvent session+ let h = nextEvent session >>= h'+ h' e = handleDirection e (move h) $ handleDirection (L.map toLower e) run $ handleModifier e h $@@ -166,19 +171,23 @@ "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 state >> shutdown session+ "S" -> saveGame lvl mstate >> shutdown session "Q" -> shutdown session- "Escape" -> shutdown session+ "Escape" -> displayCurrent "Press Q to quit." >> h -- wait "space" -> loop session nlvl nstate "" "period" -> loop session nlvl nstate "" -- look- "colon" -> displayCurrent (lookAt True nlmap ploc) >> h+ "colon" -> lookAround h -- display modes "V" -> handle session nlvl (toggleVision state) per oldmsg@@ -187,7 +196,11 @@ "T" -> handle session nlvl (toggleTerrain state) per oldmsg -- meta information- "M" -> displayCurrent lmeta >> h+ "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@@ -195,11 +208,19 @@ 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 = displayLevel session nlvl per state+ 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)@@ -208,32 +229,60 @@ -- 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 state (const nplayer)+ nstate = updatePlayer mstate (const nplayer) -- picking up items- pickup abort =+ 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- case titems t of- [] -> displayCurrent "nothing here" >> abort- (i:rs) -> - case assignLetter (mletter nplayer) (mitems nplayer) of- Just l ->- let msg = -- (complete sentence, more adequate for monsters)- {-- subjectMonster (mtype player) ++ " " ++- compoundVerbMonster (mtype player) "pick" "up" ++ " " ++- objectItem (itype i) ++ "."- -}- [l] ++ " - " ++ objectItem (itype i)- nt = t { titems = rs }- plmap = M.insert ploc (nt, nt) nlmap- iplayer = nplayer { mitems = i { iletter = Just l } : mitems nplayer,- mletter = l }- in loop session (updateLMap lvl (const plmap))- (updatePlayer nstate (const iplayer)) msg- Nothing -> displayCurrent "cannot carry anymore" >> abort+ 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 =@@ -259,14 +308,14 @@ _ -> 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')+ 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+ Tile (Stairs _ vdir' next) is | vdir == vdir' -> -- ok case next of Nothing -> -- exit dungeon@@ -293,22 +342,22 @@ False -- attacks are disallowed while running (\ l p -> loop session l (updatePlayer nstate (const p))) abort- nlvl mplayer per APlayer dir+ 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+ (_:_, _) -> 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 per APlayer dir+ 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@@ -325,19 +374,198 @@ True -- attacks are allowed (\ l p -> loop session l (updatePlayer nstate (const p))) abort- nlvl nplayer per APlayer dir+ 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 per+ nlvl@(Level { lmap = nlmap }) player assocs discs per actor dir -- to prevent monsters from hitting themselves | dir == (0,0) = continue nlvl player ""@@ -374,7 +602,7 @@ | accessible nlmap aloc naloc = updateActor (\ m -> m { mloc = naloc }) (\ _ l p -> continue l p (if actor == APlayer- then lookAt False nlmap naloc else ""))+ then lookAt False assocs discs nlmap naloc else "")) actor nlvl player | otherwise = abort where am :: Monster@@ -384,7 +612,7 @@ source = nlmap `at` aloc naloc = shift aloc dir target = nlmap `at` naloc- attackedPlayer = if mloc player == naloc then [APlayer] else []+ attackedPlayer = [ APlayer | mloc player == naloc ] attackedMonsters = L.map AMonster $ findIndices (\ m -> mloc m == naloc) (lmonsters nlvl) attacked :: [Actor]