hoodie-0.1.0.0: Main.hs
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Main where
-- base, mtl, array, containers, random, monad-loops, ncurses, astar, hfov
import Control.Monad.State
import Data.Array.IArray
import Data.Array.IO
import Data.List (sortBy, find)
import Data.Ord (comparing)
import qualified Data.Set as Set
import Data.Maybe
import System.Random
import Control.Monad.Loops (iterateUntil)
import Data.Graph.AStar (aStar)
import UI.NCurses
import FOV
type Vector2 = (Int, Int)
type Room = (Vector2, Vector2) -- xy, size
type LevelPart = [(Vector2, Char)] -- update for array
-- change Level to include entities, dlvl, and narr,
-- then change dungeon to [dungeon] to allow many levels
type Level = Array Vector2 Char
type Neighbours = Array Vector2 (Set.Set Vector2)
newtype GameT s m a = GameT (StateT s m a)
deriving (Functor, Monad, MonadIO, MonadTrans, MonadState s)
type Game = GameT GameState Curses
runGame1 :: GameState -> Game a -> Curses GameState
runGame1 s (GameT f) = execStateT f s
io :: IO a -> Game a
io = liftIO
curses :: Curses a -> Game a
curses = lift
data Side = T | B | L | R -- room sides
data ItemType = Weapon -- ']'
| Armor -- '['
| Potion -- '!'
| Scroll -- '?'
| Corpse -- '%'
deriving (Eq, Show, Read)
data ItemEffect = None
| Healing Int
| Death
| Teleport
| Yuck
deriving (Eq, Show, Read)
-- TODO: use this
data EntityStats = EntityStats
{ strength :: Int
, agility :: Int
, intelligence :: Int
, beauty :: Int
} deriving (Eq, Show, Read)
data Item = Item
{ iType :: ItemType
, iName :: String
, iSpeed :: Int
, iDamage :: Int
, iDefence :: Int
, iWeight :: Int -- mass in grams
, iEffect :: ItemEffect
} deriving (Eq, Show, Read)
data Inventory = Inventory
{ equWeapon :: Item
, equArmor :: Item
, equMisc :: Item
, storedItems :: [Item]
} deriving (Eq, Show, Read)
data Entity = Entity
{ pc :: Bool
, pos :: Vector2
, sym :: Char
, name :: String
, hp :: (Int, Int)
, inv :: Inventory
, weight :: Int -- mass in grams
, speed :: Int
, nextMove :: Int
, seenL :: Array Vector2 Bool -- ^what the player has seen of the level
, seeingL :: Array Vector2 Bool -- ^what the player *currently* sees
} deriving (Eq, Show, Read)
data GameState = GameState
{ level :: Level
, entities :: [Entity]
, items :: [(Vector2, Item)]
, msgs :: [(Int, Bool, String)] -- ^ turn added, seen by player, message
, turn :: Int
, pquit :: Bool
, narr :: Neighbours
, dlvl :: Int
} deriving (Eq, Show, Read)
-- | get the next actor and the rest
entityPQ :: [Entity] -> (Entity, [Entity])
entityPQ en =
let (p:ren) = sortBy (comparing nextMove) en
in (p, ren)
-- | get the player character and the rest
getPC :: [Entity] -> (Entity, [Entity])
getPC en =
let l = sortBy (comparing pc) en
in (last l, init l)
-- | check if the Entity is the player character
isPC :: Entity -> Bool
isPC = pc
-- empty level
emptyL :: Level
emptyL = listArray ((1,1), (80, 22)) (repeat ' ')
-- enemies don't use seenL/seeingL, so use this dummy array
nullA :: Array Vector2 Bool
nullA = listArray ((1,1), (2,2)) (repeat False)
testWeapons :: [Item]
testWeapons = [Item Weapon "Sword of Test +1" 100 4 0 1500 None
,Item Weapon "Shard of Glass" 150 2 0 300 None
,Item Weapon "Staff of Skepticism" 50 10 0 4000 None
]
testArmors :: [Item]
testArmors = [Item Armor "Tested Leather Armor" 100 0 1 5000 None
,Item Armor "Fancy Suit" 150 0 0 2000 None
,Item Armor "Power Armor mk2" 66 0 6 30000 None
]
testMisc :: [Item]
testMisc = [Item Scroll "Scroll of Modern Medicine" 100 0 0 100 (Healing 6)
,Item Potion "Potion of Alcohol" 100 0 0 700 (Healing (-1))
,Item Potion "Homeopathic Potion" 100 0 0 500 (Healing 0)
,Item Scroll "Scroll of Death" 100 0 0 100 Death
,Item Scroll "Book of Teleportation" 100 0 0 1000 Teleport
,Item Corpse "Rodent Corpse" 100 0 0 1000 Yuck
]
testEnemies :: [Entity]
testEnemies =
[Entity False (0,0) 'L' "Lamar" (5,5) undefined 30000 50 0 nullA nullA
,Entity False (0,0) 'A' "Giant Ant" (7,7) undefined 10000 99 0 nullA nullA
,Entity False (0,0) 'm' "Mom" (8,8) undefined 60000 101 0 nullA nullA
,Entity False (0,0) 'b' "Bear" (13,13) undefined 120000 120 0 nullA nullA
,Entity False (0,0) 'd' "Dog" (3,3) undefined 8000 95 0 nullA nullA
,Entity False (0,0) 'a' "Armadillo" (1,1) undefined 1000 85 0 nullA nullA
]
testBoss :: Entity
testBoss =
Entity False (0,0) 'G' "Dreadlord Gates" (32,32)
undefined 75000 135 0 nullA nullA
testItems :: [Item]
testItems = testWeapons ++ testArmors ++ testMisc
randInv :: IO Inventory
randInv = do
w <- randomElem testWeapons
a <- randomElem testArmors
m <- randomElem testMisc
return Inventory { equWeapon = w
, equArmor = a
, equMisc = m
, storedItems = [] }
-- to save disk space, the neighbours array could be discarded here
-- and then rebuilt on load
save :: Game ()
save = get >>= io . writeFile "savefile" . show
load :: Game ()
load = io (readFile "saveFile") >>= io . readIO >>= put
mkPlayer :: Vector2 -> IO Entity
mkPlayer pos' = do
pinv <- randInv
return Entity
{ pc = True
, name = "Player"
, pos = pos'
, sym = '@'
, hp = (20, 20)
, inv = pinv
, weight = 75000
, speed = 100
, nextMove = 0
, seenL = listArray ((1,1), (80,22)) (repeat False)
, seeingL = listArray ((1,1), (80,22)) (repeat False)
}
mkEnemiesOnLevel :: Int -- number of enemies
-> Int -- nextMove of enemies, set to the nextMove of the player
-- when descending the dungeon
-> Level
-> IO [Entity]
mkEnemiesOnLevel dl nm l = do
en <- randomRIO (1 * dl, 3 * dl) -- amount of enemies
es <- randFloors l en -- positions
ei <- replicateM en randInv -- inventories
em <- replicateM en (randomElem testEnemies) -- random enemies
ep <- randFloor l -- position of boss, maybe
bi <- randInv -- inventory of boss, maybe
return $
-- add the boss on the fifth level
[testBoss { pos = ep, inv = bi, nextMove = nm } | dl == 5] ++
-- add normal enemies
zipWith3 (\e p i -> e { pos = p, inv = i, nextMove = nm }) em es ei
mkItemsOnLevel :: Level -> IO [(Vector2, Item)]
mkItemsOnLevel l = do
i <- randomRIO (3,9)
is <- replicateM i (randomElem testItems)
ip <- randFloors l i
return (zip ip is)
-- | Creates a brand-new, fully filled Game.
mkDungeonLevel :: Game ()
mkDungeonLevel = do
l <- io $ mkRandRooms (80, 22) -- dungeon, or level
p <- io $ randFloor l -- player position
ep <- io $ randFloor l -- exit position
is <- io $ mkItemsOnLevel l
p' <- io $ mkPlayer p -- player position
entities' <- io $ mkEnemiesOnLevel 1 0 l
put GameState
{ entities = p' : entities'
, items = is
, level = l // [(ep, '>')]
, msgs = [(0, False, "Welcome to hoodie! (press ? for help)")]
, turn = 0
, pquit = False
, narr = mkNeighbourArray l ".⋅+#SDk"
, dlvl = 1
}
-- | changes all the things that need the change between floors
descendLevel :: Game ()
descendLevel = do
g <- get
let (p,_) = getPC (entities g) -- get player
l <- io $ mkRandRooms (80, 22)
pp <- io $ randFloor l -- new player position
ep <- io $ randFloor l -- exit position
is <- io $ mkItemsOnLevel l
let dlvl' = dlvl g + 1
p' = p { pos = pp
, seenL = listArray ((1,1), (80,22)) (repeat False)
, seeingL = listArray ((1,1), (80,22)) (repeat False)
}
entities' <- io $ mkEnemiesOnLevel dlvl' (nextMove p + 1) l
put $ g
{ entities = p' : entities'
-- level 5 is the last level
, level = if dlvl' == 5 then l else l // [(ep, '>')]
, narr = mkNeighbourArray l ".⋅+#SDk"
, items = is
, dlvl = dlvl'
}
-- | make a random pair within given bounds
randomV2 :: (Vector2, Vector2) -> IO Vector2
randomV2 ((x1, y1), (x2, y2)) = do
x <- randomRIO (x1, x2)
y <- randomRIO (y1, y2)
return (x,y)
isFloor :: Level -> Vector2 -> Bool
isFloor l p = l ! p `elem` ".⋅"
-- | find a random part of the level that's walkable
randFloor :: Level -> IO Vector2
randFloor l = iterateUntil (isFloor l) (randomV2 (bounds l))
-- | find n non-repeating random positions that are walkable
randFloors :: Level -> Int -> IO [Vector2]
randFloors l n =
flip execStateT [] $
replicateM_ n $ do
ps' <- get
xy <- iterateUntil (`notElem` ps') (liftIO $ randFloor l)
modify (xy:)
-- | check if two rooms overlap
roomOverlap :: Room -> Room -> Bool
roomOverlap ((x1, y1), (sx1, sy1)) ((x2, y2), (sx2, sy2)) =
not (x1 > x2 + sx2 + 1
||y1 > y2 + sy2 + 1
||x2 > x1 + sx1 + 1
||y2 > y2 + sy1 + 1)
-- | check if the given room overlaps any of the rooms in the list
roomOverlapAny :: Room -> [Room] -> Bool
roomOverlapAny r = any (roomOverlap r)
-- | create a room without checking if it's within level bounds
createRoom :: Vector2 -> IO Room
createRoom (sx, sy) = do
-- all rooms need to be at least 2 tiles away from the level bounds
-- 1 tile to make room for any paths, and +1 tile because FOV crashes
-- if it tries to look at nothingness.
x <- randomRIO (3, sx - 3)
y <- randomRIO (3, sy - 3)
rx <- randomRIO (2, sx `div` 2)
ry <- randomRIO (2, sy `div` 2)
return ((x, y), (rx, ry))
-- | check if a room is within (x2, y2) bounds
goodRoom :: Vector2 -> Room -> Bool
goodRoom (sx, sy) ((x, y), (rx, ry)) = x + rx < sx - 3 && y + ry < sy - 3
-- | try really hard to make a servicable dungeon
mkRandRooms :: Vector2 -> IO Level
mkRandRooms lbounds = do
-- try 1000 times to create good non-overlapping rooms
rooms <- flip execStateT [] $
replicateM_ 1000 $ do
rooms <- get
r <- iterateUntil (goodRoom lbounds) (liftIO (createRoom lbounds))
unless (r `roomOverlapAny` rooms) (modify (r:))
when (null rooms)
(error "dungeon generator mkRandRooms didn't make any rooms")
let room_lps = mkRooms rooms :: LevelPart
narrP = mkNeighbourArray (emptyL // room_lps) " "
paths1 <- connectRandomRoomToAll narrP rooms
paths2 <- connectRandomRooms narrP rooms (length rooms `div` 2)
return $ emptyL // (room_lps ++ paths1 ++ paths2)
-- | connect a random room from the list to all rooms. Cheap way to
-- ensure that all rooms are connected.
connectRandomRoomToAll :: Neighbours -> [Room] -> IO LevelPart
connectRandomRoomToAll narrP rooms = do
rc <- randomElem rooms
concat `fmap` catMaybes `fmap` forM rooms (\r ->
if r /= rc
then connectRooms narrP r rc
else return Nothing)
-- | make n random connections between rooms
connectRandomRooms :: Neighbours -> [Room] -> Int -> IO LevelPart
connectRandomRooms narrP rooms n =
concat `fmap` catMaybes `fmap` replicateM n
(do r1 <- randomElem rooms
r2 <- randomElem rooms
if r1 /= r2 then connectRooms narrP r1 r2
else return Nothing)
-- | connect two rooms, using corridors generated by A* pathfinding.
-- Randomly picks a side, so all rooms must have one tile free space
-- around them.
connectRooms :: Neighbours -> Room -> Room -> IO (Maybe LevelPart)
connectRooms narrP r1 r2 = do
side1 <- randomRIO (1, 4::Int)
side2 <- randomRIO (1, 4::Int)
let (f1, r1p') =
case side1 of
1 -> (above, roomSideR r1 T)
2 -> (below, roomSideR r1 B)
3 -> (left, roomSideR r1 L)
4 -> (right, roomSideR r1 R)
_ -> error "wait, what?"
(f2, r2p') =
case side2 of
1 -> (above, roomSideR r2 T)
2 -> (below, roomSideR r2 B)
3 -> (left, roomSideR r2 L)
4 -> (right, roomSideR r2 R)
_ -> error "you're drunk; go home"
r1p <- r1p'
r2p <- r2p'
return $ mkPath narrP r1p r2p f1 f2
-- | produce a random tile location from given side of the given room
roomSideR :: Room -> Side -> IO Vector2
roomSideR ((x1, y1), (sx, sy)) s =
case s of
T -> randomRIO (x1+1, x1+sx-1) >>= \x -> return (x, y1)
B -> randomRIO (x1+1, x1+sx-1) >>= \x -> return (x, y1+sy)
R -> randomRIO (y1+1, y1+sy-1) >>= \y -> return (x1+sx, y)
L -> randomRIO (y1+1, y1+sy-1) >>= \y -> return (x1, y)
-- utils for Data.Graph.AStar
-- | distance between two level points (taxi metric)
distance :: Vector2 -> Vector2 -> Int
distance (a1,a2) (b1, b2) =
(b1 - a1) + (b2 - a2)
maybeLookup :: Level -> Vector2 -> Maybe Char
maybeLookup l p@(x,y) =
let ((x1, y1), (x2, y2)) = bounds l
in if x > x2 || x < x1 || y > y2 || y < y1
then Just (l ! p)
else Nothing
-- | create a array of the sets of neighbours for each tile
mkNeighbourArray :: Level -> String -> Neighbours
mkNeighbourArray l tt =
let (a@(x1,y1), b@(x2,y2)) = bounds l
in listArray (a, b) [setOfNeighbours l tt (x,y) |
x <- [x1..x2],
y <- [y1..y2]]
-- | create a set of all neighbours of a point that are walkable
setOfNeighbours :: Level -> String -> Vector2 -> Set.Set Vector2
setOfNeighbours l tt p =
Set.fromList
. map fst
. filter (\(p',_) -> l ! p' `elem` tt)
. filter (\(_,m) -> isNothing m) $
[ (above p, l `maybeLookup` above p)
, (below p, l `maybeLookup` below p)
, (right p, l `maybeLookup` right p)
, (left p, l `maybeLookup` left p)]
-- | aStar with defaults
simpleAStar :: Neighbours
-> Vector2
-> Vector2
-> Maybe [Vector2]
simpleAStar narrP start goal =
let adjdist _ _ = 1
nset p = narrP ! p
dist = distance goal
in aStar nset adjdist dist (==goal) start
-- | make a path between two rooms
mkPath :: Neighbours
-> Vector2 -- ^ from
-> Vector2 -- ^ to
-> (Vector2 -> Vector2)
-- pass above/below/right/left here, because if we're making
-- a path from a room, the first tile and last tiles are
-- impassable walls
-> (Vector2 -> Vector2)
-> Maybe LevelPart
mkPath narrP p1 p2 f1 f2 = do
p' <- simpleAStar narrP (f1 p1) (f2 p2)
return $ zip p' (repeat '#') ++ [(f1 p1, '#'), (p1,'+'), (p2,'+')]
-- level construction
mkHwall :: Char -> Int -> Vector2 -> LevelPart
mkHwall ch len (x,y) = zip (zip [x..(x-1+len)] (repeat y)) (repeat ch)
mkVwall :: Char -> Int -> Vector2 -> LevelPart
mkVwall ch len (x,y) = zip (zip (repeat x) [y..(y-1+len)]) (repeat ch)
-- borders:
-- ┘ ┐ ┌ └ │ ─ ├ ┬ ┤ ┴ ┼ ╭ ╮ ╯ ╰
-- ═ ║ ╒ ╓ ╔ ╕ ╖ ╗ ╘ ╙ ╚ ╛ ╜ ╝ ╞ ╟
-- ╠ ╡ ╢ ╣ ╤ ╥ ╦ ╧ ╨ ╩ ╪ ╫ ╬
mkRoom :: Room -> LevelPart
mkRoom ((x1, y1), (sx, sy)) = concat
-- floors
[[((x,y), '⋅') | y <- [y1..(y1+sy)], x <- [x1..(x1+sx)]]
-- walls
,mkHwall '═' sx (x1, y1)
,mkHwall '═' sx (x1, y1 + sy)
,mkVwall '║' (sy+1) (x1, y1)
,mkVwall '║' (sy+1) (x1 + sx, y1)
-- corners
,[((x1, y1), '╔'), ((x1+sx, y1+sy), '╝')
,((x1, y1+sy), '╚'), ((x1+sx, y1), '╗')]]
mkRooms :: [Room] -> LevelPart
mkRooms = concatMap mkRoom
walkableL :: Level -> Vector2 -> Bool
walkableL l p@(x,y) =
let ((x1,y1), (x2,y2)) = bounds l
in (x < x2 || x > x1 || y < y2 || y > y1) && (l ! p `elem` ".⋅+#SDk>")
-- TODO: this needs to be fixed to account for messages over 75 chars
displayMessageLog :: Game ()
displayMessageLog = do
g <- get
let ((x1,_), (x2,y2)) = bounds (level g)
curses $ draw $ do
clear (bounds (level g))
drawStringAt (1,1) "Message log: ('p' to return)"
forM_ (zip [3..] (take (y2 - 5) (msgs g))) $ \(n,(t,_,m)) ->
drawStringAt (x1, n) $ take (x2 - 5) "[" ++ show t ++ "] " ++ m
_ <- curses $ waitForChrs "p"
curses $ draw (clear (bounds (level g)))
helpString :: [String]
helpString = ["Hello, hoodie here (press ? again to return)"
,""
,"Move with the Vi keys: hijkyubn"
,"Attack by moving into enemies"
,"Wait for a turn by pressing ."
,"i to look at your inventory"
,"a to apply your misc item"
,", to pick up items below you"
,"Descend to the next level with > when you are on stairs"
,"Press p to display the message log,"
,""
,"q to quit, coward."]
displayHelp :: Game ()
displayHelp = do
g <- get
curses $ draw $ do
clear (bounds (level g))
forM_ [1..length helpString] $ \y ->
drawStringAt (1, y) $ center 80 (helpString !! (y-1))
_ <- curses $ waitForChrs "?"
curses $ draw (clear (bounds (level g)))
displayPlayerInventory :: Game ()
displayPlayerInventory = do
p <- (fst . getPC) `fmap` gets entities
addMessage $ "Inventory: W: "
++ iName (equWeapon (inv p)) ++
" A: " ++ iName (equArmor (inv p)) ++
" M: " ++ iName (equMisc (inv p))
withReverse :: Update () -> Update ()
withReverse upact = do
setAttribute AttributeReverse True
upact
setAttribute AttributeReverse False
itemSym :: Item -> Char
itemSym i = case iType i of
Weapon -> ']'
Armor -> '['
Potion -> '!'
Scroll -> '?'
Corpse -> '%'
drawEverything :: Game ()
drawEverything = do
g <- get
l <- gets level
let (p, en') = getPC (entities g)
seen = seenL p
seeing = seeingL p
curses $ draw $ do
clear (bounds l)
-- draw level
forM_ (indices l) $ \i -> do
when (seen ! i) (drawStringAt i [l ! i])
when (seeing ! i) (withReverse (drawStringAt i [l ! i]))
-- draw items
forM_ (items g) $ \(ip,i) ->
when (seeing ! ip) (drawStringAt ip [itemSym i])
-- draw enemies
forM_ en' $ \e ->
when (seeing ! pos e) (drawStringAt (pos e) [sym e])
-- draw player
withReverse $ drawStringAt (pos p) "@"
-- concat unseen messages and draw them
let dms = concat $ reverse $ map (\(_,_,m) -> m++" ") $
takeWhile (\(_,b,_) -> not b) (msgs g)
unless (null dms) $
withReverse $ drawStringAt (1,1) dms
-- draw a statusbar, displaying time, speed, dungeon level, and hp
withReverse $ drawStringAt (1, 24) $
"Time: " ++ show (nextMove p) ++ " Speed: " ++ show (speed p)
++ " DL: " ++ show (dlvl g) ++ " HP: " ++ show (fst (hp p))
++ "/" ++ show (snd (hp p))
above, below, right, left :: Vector2 -> Vector2
above (x, y) = (x, y - 1)
below (x, y) = (x, y + 1)
right (x, y) = (x + 1, y)
left (x, y) = (x - 1, y)
aboveleft, aboveright, belowleft, belowright :: Vector2 -> Vector2
aboveleft (x, y) = (x - 1, y - 1)
aboveright (x, y) = (x + 1, y - 1)
belowleft (x, y) = (x - 1, y + 1)
belowright (x, y) = (x + 1, y + 1)
-- | maps directional keys to movement functions
keyToDir :: Char -> Vector2 -> Vector2
keyToDir c =
case c of
'k' -> above
'j' -> below
'l' -> right
'h' -> left
'y' -> aboveleft
'u' -> aboveright
'b' -> belowleft
'n' -> belowright
'.' -> id
_ -> error "movePlayer: controls misconfigured"
-- | Move the player, fail to move the player, rest, or attack an entity
movePlayer :: Char -> Game ()
movePlayer c = do
l <- gets level
en <- gets entities
is <- gets items
let (p,en') = getPC en
-- position player wants to move to
newp = keyToDir c (pos p)
-- is there someone there?
case en' `getEntityAt` newp of
-- we're moving into an enemy
Just e -> attackEntity p e
-- or not
Nothing ->
if l `walkableL` newp
then do
let i = newp `lookup` is
when (isJust i) $ addMessage $ "You see here the "++iName (fromJust i)
p `moveEntityTo` newp
else addMessage "You bump into an obstacle!"
modifyEntityAt :: [Entity] -> Vector2 -> (Entity -> Entity) -> [Entity]
modifyEntityAt es p f =
map (\e -> if e == fromJust (es `getEntityAt` p) then f e else e) es
modifyEntityHp :: Int -> Entity -> Entity
modifyEntityHp n e =
let (hp', maxhp') = hp e
newhp = min maxhp' (hp' + n)
in e { hp = (newhp, maxhp') }
removeEntityAt :: [Entity] -> Vector2 -> [Entity]
removeEntityAt es p = filter (\e -> pos e /= p) es
getEntityAt :: [Entity] -> Vector2 -> Maybe Entity
getEntityAt es p = find (\e -> pos e == p) es
anyEntityAt :: [Entity] -> Vector2 -> Bool
anyEntityAt es p = p `elem` map pos es
addMessage :: String -> Game ()
addMessage m = do
g <- get
put $ g { msgs = (turn g, False, m) : msgs g }
descend :: Game ()
descend = do
g <- get
if level g ! pos (fst (getPC (entities g))) == '>'
then do
curses $ draw $ clear (bounds (level g))
descendLevel
addMessage "You descend into the next level!"
else addMessage "There are no stairs here!"
-- | merge the old "seen" array with the new "seeing" array
-- to produce an updated "seen" array
updateSeen :: Array Vector2 Bool
-> Array Vector2 Bool
-> IO (Array Vector2 Bool)
updateSeen old_seen new_seeing = do
u_n_s <- thaw new_seeing :: IO (IOArray Vector2 Bool)
upds <- filter snd `fmap` getAssocs u_n_s
return $ old_seen // upds
-- | update the "seen" and "seeing" arrays
updateVision' :: GameState -> IO GameState
updateVision' g = do
let l = level g
(p,en') = getPC (entities g)
pp = pos p
seen = seenL p
(seeing',seen') <- do
s <- ioInit
newSeeing <- newArray (bounds l) False :: IO (IOUArray Vector2 Bool)
let lightPoint x y = writeArray newSeeing (x, y) True
isOpaque x y = return (l ! (x, y) `elem` " ═║╔╝╚╗")
-- use FOV's circle to write into the newSeeing array
circle s pp 5 lightPoint isOpaque
newSeeing' <- freeze newSeeing :: IO (Array Vector2 Bool)
newSeen' <- updateSeen seen newSeeing'
return (newSeeing', newSeen')
let np = p { seenL = seen', seeingL = seeing' }
g' = g { entities = np:en' }
return g'
getGoodCh :: Game Char
getGoodCh = curses $ waitForChrs "?hjklyubnqsdpria.,>"
setQuit :: Game ()
setQuit = do
g <- get
put $ g { pquit = True }
-- | Checks if the player is dead and quits if they are.
isPlayerDead :: Game ()
isPlayerDead = do
en <- gets entities
let php = fst . hp .fst . getPC $ en
when (php <= 0) $ do
addMessage "Oh no! You are dead!"
setQuit
-- | Turn or time is a measure of how long the player has been in the dungeon.
-- An entity with 100 speed and 100 speed armor takes 10 "time" to move one
-- square. Higher speed = less time taken.
setTurn :: Game ()
setTurn = do
g <- get
let p = fst . getPC $ entities g
put $ g { turn = nextMove p }
-- | This is the main update function, updating one entity per call. The
-- entity to be updated is the one with the lowest nextMove value. When the
-- entity perform a task (including nothing at all), the time cost of the task
-- is added to its nextMove. "turn" is used for the lack of a better word.
gameTurn :: Game ()
gameTurn = do
processNegativeHpEntities
g <- get
let en@(e, _) = entityPQ (entities g)
if isPC e
then do
setTurn
drawEverything
ageMessages
c <- getGoodCh
case c of
'q' -> setQuit
'p' -> displayMessageLog
'?' -> displayHelp
',' -> playerPickupItem
'a' -> entityApplyItem e
'i' -> displayPlayerInventory
's' -> save
'd' -> load
'r' -> mkDungeonLevel >> updateVision
'>' -> descend >> updateVision
_ -> movePlayer c >> updateVision
else processEnemies en
isPlayerDead
modifyEntity :: Entity -> (Entity -> Entity) -> Game ()
modifyEntity e f = do
g <- get
en <- gets entities
put $ g { entities = map (\e' -> if e' == e then f e' else e') en }
-- | The time needed to perform an action is:
--
-- 1000
-- --------------------------------------
-- (speed of entity + speed of item used)
-- ----------------------------------
-- 2
--
-- or equivalently: 2000 / (speed of entity + speed of item used)
--
-- for moving around, the item speed used is that of the equipped armor
itemUseCost :: Entity -> Item -> Int
itemUseCost e i = 2000 `div` (speed e + iSpeed i)
-- TODO: consume item or item charge on use
-- | Use your misc item to do something
entityApplyItem :: Entity -> Game ()
entityApplyItem e = do
g <- get
let (p, _) = getPC (entities g)
pm = equMisc (inv e)
verb = case iType pm of
Potion -> "drink"
Scroll -> "read"
Corpse -> "squeeze"
_ -> "use"
useMsg =
if e == p
then "You " ++ verb ++ " the " ++ iName pm ++ "!"
-- don't bother using verbs for others :)
else name e ++ " uses the " ++ iName pm ++ "!"
case iEffect pm of
None ->
return ()
Healing n -> do
addMessage useMsg
modifyEntity e ( modifyEntityHp n
. addEntityTime (itemUseCost e pm))
Death -> do
-- always add useMsg
addMessage useMsg
-- only add these when the player uses items
when (e == p) $ addMessage "You feel stupid!"
modifyEntity e ( modifyEntityHp (-999))
Teleport -> do
addMessage useMsg
newp <- io $ randFloor (level g)
modifyEntity e (modifyEntityPos newp)
addMessage "Woosh!"
updateVision
Yuck -> do
addMessage useMsg
when (e == p) $ addMessage "Yuck!"
-- | Pick up an item, if there is one below the player.
playerPickupItem :: Game ()
playerPickupItem = do
g <- get
-- items on the floor
let is = items g
-- player and friends
(p, en) = getPC (entities g)
-- current inventory
cinv = inv p
-- is there an item below us?
case pos p `lookup` is of
Nothing ->
addMessage "There's nothing here to pick up!"
Just i -> do
-- make a new inventory based on the type of the item
let newinv = case iType i of
Weapon -> cinv { equWeapon = i }
Armor -> cinv { equArmor = i }
_ -> cinv { equMisc = i }
-- item we're dropping from the player's inventory
dropped = case iType i of
Weapon -> equWeapon (inv p)
Armor -> equArmor (inv p)
_ -> equMisc (inv p)
-- commit new inventory, remove the item from the floor
-- and add the dropped item to the floor at the player's feet
put $ g { entities = p { inv = newinv } : en
, items = (pos p, dropped) : filter (/= (pos p, i)) is
}
-- picking stuff up takes time
modifyEntity p (addEntityTime (itemUseCost p i))
-- add message
addMessage $ "You pick up the " ++ iName i ++ "!"
-- | After one turn, set messages to viewed so they don't display any more
ageMessages :: Game ()
ageMessages = do
g <- get
put $ g { msgs = map (\(t,_,m) -> (t, True, m)) (msgs g) }
updateVision :: Game ()
updateVision = get >>= io . updateVision' >>= put
-- | Checks if the Entity current hp <= 0.3 of max
panicEntityAI :: Entity -> Bool
panicEntityAI e =
let (cHp, mHp) = hp e
hpRatio = fromIntegral cHp / fromIntegral mHp :: Double
in hpRatio <= 0.3
processEnemies :: (Entity, [Entity]) -> Game ()
processEnemies (e, en) = do
let p = (fst . getPC) en
if panicEntityAI e
-- if the entity has low hp then use its misc item
then entityApplyItem e
else
-- if the enemy is next to the player, attack, otherwise
-- move closer to the player
if pos e `nextTo` pos p
then e `attackEntity` p
else moveEntityAI en e
-- | subtract damage from defender, add time spent to the attacker, and
-- add messages
attackEntity :: Entity -- attacker
-> Entity -- defender
-> Game ()
attackEntity atk def = do
let -- inventories of the attacker and defender
aw = equWeapon (inv atk)
da = equArmor (inv def)
-- damage done from attacker to defender is attacker's weapon attack
-- value minus defender's armor's defend value
dmg = max 0 (iDamage aw - iDefence da)
-- add messages
when (isPC def) $ addMessage $ "The " ++ name atk ++ " hits you!"
when (isPC atk) $ addMessage $ "You hit the " ++ name def ++ "!"
unless (isPC def || isPC atk) $
addMessage $ "The " ++ name atk ++ "hits the " ++ name def ++ "!"
-- damage the defender
modifyEntity def (modifyEntityHp (-dmg))
-- add attack cost to the attacker
modifyEntity atk (addEntityTime (itemUseCost atk aw))
-- | remove entities that have <= 0 current hitpoints and add messages about
-- their deaths
processNegativeHpEntities :: Game ()
processNegativeHpEntities = do
g <- get
let died = filter (\e -> fst (hp e) <= 0) (entities g)
unless (null died) $
-- death messages
do let dms = map (\e -> name e ++ " dies!") died
-- entities that are still alive
new = filter (`notElem` died) (entities g)
-- create corpses to drop at the positions where
-- the entities died
corpses = map (\e -> (pos e, entityToCorpse e)) died
-- add messages
mapM_ addMessage dms
g' <- get
put $ g' { entities = new, items = corpses ++ items g' }
entityToCorpse :: Entity -> Item
entityToCorpse e =
Item { iType = Corpse
, iName = name e ++ " corpse"
, iSpeed = 100
, iDamage = 0
, iDefence = 0
, iWeight = weight e
, iEffect = Yuck
}
-- | cartesian distance function
cartDistance :: Vector2 -> Vector2 -> Double
cartDistance (x1, y1) (x2, y2) =
sqrt $ fromIntegral $ (x2-x1)^(2::Int) + (y2-y1)^(2::Int)
-- | all the directions you could ever possibly want to move in to including none
directions :: [Vector2 -> Vector2]
directions =
[id, above, below, right, left
,aboveright, aboveleft
,belowright, belowleft]
-- | calculate the distances between two points if you were to move the
-- *first* point in all possible directions
distances :: Vector2 -> Vector2 -> [Double]
distances a b =
map (\f -> cartDistance (f a) b) directions
-- | Check if a is next to b
nextTo :: Vector2 -> Vector2 -> Bool
nextTo a b = any (\f -> a == f b) directions
modifyEntityPos :: Vector2 -> Entity -> Entity
modifyEntityPos new e = e { pos = new }
addEntityTime :: Int -> Entity -> Entity
addEntityTime n e = e { nextMove = nextMove e + n }
moveEntityTo :: Entity -> Vector2 -> Game ()
moveEntityTo e newp =
modifyEntity e ( modifyEntityPos newp
. addEntityTime (itemUseCost e (equArmor (inv e)))
)
-- | make a list of functions sorted by the distance that they would bring
-- the enemy to if it moved in that direction, then select the first good one
moveEntityAI :: [Entity] -- rest of the enemies
-> Entity -- the entity we're moving
-> Game ()
moveEntityAI en' e = do
l <- gets level
en <- gets entities
-- player position
let pp = pos (fst (getPC en))
-- entity position
ep = pos e
-- sort the movement functions by the distance that they would
-- bring the enemy to if it moved into that direction
sorted_funs = map snd $ sortBy (comparing fst)
(zip (distances ep pp) directions)
-- is this tile a good move?
goodmove ne = (l `walkableL` ne -- is the tile traversable?
-- is there an enemy on it?
&& not (en' `anyEntityAt` ne))
-- we can also just stand still
&& ne /= pp
-- get the first function that's a good move. Since they're sorted
-- by ascending distance, it's the optimal move. There is always
-- at least one element of this list - id.
bestfunc = head $ dropWhile (\f -> not (goodmove (f ep))) sorted_funs
-- enemies have a detection radius of 10, if the player is outside
-- it then just stand still
e `moveEntityTo` (if cartDistance ep pp < 10 then bestfunc ep else ep)
quitCond :: Game Bool
quitCond = liftM pquit get
runGame :: Game Bool -- ^ end condition
-> Game () -- ^ update function
-> IO GameState -- ^ end state
runGame predf logicf = do
let loop' = do
doquit <- predf
if doquit
then get
else logicf >> loop'
runCurses $ do
setEcho False
_ <- setCursorMode CursorInvisible
runGame1 undefined $ do
mkDungeonLevel
updateVision
loop'
main :: IO ()
main = do
g <- runGame quitCond gameTurn
mapM_ print (reverse (msgs g))
-- FOV init
ioInit :: IO Settings
ioInit = do
settings <- newSettings
setShape settings Circle
setOpaqueApply settings True
return settings
-- ncurses stuff
draw :: Update () -> Curses ()
draw ioact = do
w <- defaultWindow
updateWindow w ioact
render
clear :: (Vector2, Vector2) -> Update ()
clear ((x1, y1), (x2, y2)) =
let cs = replicate (x2-x1) ' '
in forM_ [y1..y2+2] $ \y ->
drawStringAt (x1, y) cs
waitForChrs :: String -> Curses Char
waitForChrs cs = loop' where
loop' = do
w <- defaultWindow
ev <- getEvent w Nothing
case ev of
Nothing -> loop'
Just (EventCharacter c) -> if c `elem` cs then return c else loop'
_ -> loop'
drawStringAt :: Vector2 -> String -> Update ()
drawStringAt (x, y) s = do
moveCursor' (y - 1, x - 1)
drawString s
screenSize' :: Curses Vector2
screenSize' = screenSize >>= \(y, x) ->
return (fromIntegral y, fromIntegral x)
moveCursor' :: Vector2 -> Update ()
moveCursor' (y, x) = moveCursor (fromIntegral y) (fromIntegral x)
-- misc stuff
swap :: (a, b) -> (b, a)
swap (a, b) = (b, a)
replaceElem :: [a] -> a -> Int -> [a]
replaceElem es e n = take n es ++ e : drop (n + 1) es
randomElem :: [a] -> IO a
randomElem xs = (xs !!) `fmap` randomRIO (0, length xs - 1)
center :: Int -> String -> String
center n xs =
let padding = replicate ((n - length xs) `div` 2) ' '
in padding ++ xs ++ padding