venzone-1.0.0.0: src/Story.hs
{-# Language TemplateHaskell #-}
module Story where
import Meeple.Operate
import Input
import Plant
import Room
import Screen
import Terminal.Game
import Lens.Micro.Platform
import qualified Data.List as L
import qualified Data.Set as S
-- SWinning = win animation
data Status = SRunning | SWon Animation | SQuit
deriving (Eq, Show)
type Name = String
data Story = Story { -- read
_name :: Name,
_size :: Coords,
_rooms :: [Room],
-- state
_storyScreen :: Screen,
_spawnRoom :: Room,
-- playerstate
_stars :: Integer,
_collected :: S.Set (Name, Coords),
-- collected stars
_status :: Status
}
deriving (Eq, Show)
makeLenses ''Story
instance HasScreen Story where screen = storyScreen
defaultStory :: Story
defaultStory = buildStory "no-name" (1,1) "<no-init-title>" [defaultRoom]
-- constructor + sanity check
buildStory :: Name -> Coords -> Title -> [Room] -> Story
buildStory n c st rs
| null rs = -- check we have at least one screen
ef "no screen found"
| otherwise =
-- spawn at the initial coordinates
-- (it will check spawn in room one exists)
let s = spawn r S.empty in
-- check sizes of screen
case checkRoomSize c rs of
[] -> let lst = Story n c rs s r 0 S.empty SRunning
in -- todo [refactor] starify and fetchNeighburs
-- should be generalised, maybe inside spawn
lst & id %~ starifyScreen False
& id %~ fetchNeighbours
es -> error (mismErr c es)
where
ef s = error $ "buildStory: " ++ s ++
" in Story \"" ++ n ++ "\"!"
-- non posso usare fetchroom perché non ho ancora
-- costruito Story
r = case filter (^. title . to (== st)) rs of
(x:_) -> x
_ -> ef $ "no starting room" ++ show st
---------------
-- FUNCTIONS --
---------------
fetchRoom :: Story -> Title -> Room
fetchRoom s t = fetchRoomSafe s t ^. non e
where
e = error $ "Cannot find room named " ++ show t ++ "!"
fetchRoomSafe :: Story -> Title -> Maybe Room
fetchRoomSafe s t =
case filter f (s ^. rooms) of
(r:_) -> Just r
[] -> Nothing
where
f r = r ^. title . to (== t)
-- fetch neighbour of current room
fetchNeighbours :: Story -> Story
fetchNeighbours s =
let op = s ^. room . plant
ps = s ^. size
in s & neighbourPlant .~ gluePlants ps op ns
where
ns :: [(Cardinal, Plant)]
ns = map f (s ^. room . exits)
f :: Exit -> (Cardinal, Plant)
f (Exit c t) = (c, fr s t ^. plant)
fr :: Story -> Title -> Room
fr ws t = fetchRoomSafe ws t ^. non defaultRoom
-----------
-- LOGIC --
-----------
storyLogic :: Story -> Input -> Story
storyLogic s KExit = s & status .~ SQuit
storyLogic s _ | isWinning s = s & status %~ tickWinning
storyLogic s e = (buryDeads . deadCheck . saveCheck . oobCheck) s &
storyScreen %~ screenLogic e
isWinning :: Story -> Bool
isWinning s = case s ^. status of
SWon {} -> True
_ -> False
tickWinning :: Status -> Status
tickWinning (SWon a) = SWon $ tick a
tickWinning s = s
isWinOver :: Story -> Bool
isWinOver s = case s ^. status of
SWon a -> isExpired a
_ -> False
-- todo [refactor] hack
saveCheck :: Story -> Story
saveCheck s = case s ^. mplayer of
Nothing -> s
Just _ ->
if s ^. player ^?! _Just . amSaving
then s & spawnRoom .~ (s ^. screen . room)
& player . mapped . amSaving .~ False
else s
-- todo [refactor] refactor starify e in generale spawn
deadCheck :: Story -> Story
deadCheck s | playerDead s = s & storyScreen .~ spawn (s ^. spawnRoom)
(s ^. collected)
& id %~ starifyScreen False
& id %~ fetchNeighbours
| otherwise = s
oobCheck :: Story -> Story
oobCheck s | playerDead s = s
| pr < 1 = changeRoom N
| pr > mr = changeRoom S
| pc < 1 = changeRoom W
| pc > mc = changeRoom E
| otherwise = s
where
(pr, pc) = s ^. player .
non (error "oobCheck - no player") .
position
(mr, mc) = s ^. size
changeRoom :: Cardinal -> Story
changeRoom c =
let r = s ^. screen . room
p = s ^. screen . player .
non (error "changeRoom - no Player")
sps = s ^. collected in
case cardinalTitle r c of
Nothing -> playerDie s
Just t -> s & storyScreen .~ enter p sps (fetchRoom s t)
& id %~ starifyScreen False
& id %~ fetchNeighbours
-- xxx [refactor] really abstract this
-- from Dead elements we will get score info and such
-- (or cleanDeads)
buryDeads :: Story -> Story
buryDeads s = s & meeples .~ rs
& id %~ processDead dm
where
(dm, rs) = s ^. meeples . to (L.partition isDead)
-- todo [refactor] anche qui, dovrei swrapparli e poi
-- passarli a processdead
-- meeple
processDead :: [Meeple] -> Story -> Story
processDead ms s = foldl f s ms
where
f :: Story -> Meeple -> Story
f ws (MDead x) = g ws x
f _ _ = error "processDeads passed a non dead"
-- che succede se raccolgo una stella?
g :: Story -> Message -> Story
g ws None = ws
g ws (PlusStar cs) = consumeStar True cs ws
g ws (NeutralStar cs) = consumeStar False cs ws
g ws Won = ws & status .~ SWon winAni
winAni :: Animation
winAni = creaAnimation [(26, box ' ' 80 24)]
-- add a star: True = the player collected it
consumeStar :: Bool -> Coords -> Story -> Story
consumeStar b cs s =
if b
then s & stars +~ 1
& collected %~ S.insert (rname, cs)
& id %~ starifyScreen True
else s & collected %~ S.insert (rname, cs)
where
rname = s ^. screen . room . title
-- apply the relevant Screen changes, given a story state (i.e., locks
-- to open if we collected enough stars).
-- Bool: long lock animation?
starifyScreen :: Bool -> Story -> Story
starifyScreen b s = s & screen . meeples . each %~ f
where
-- xxx [refactor] anche qui vorrei un "is xyz" map
f :: Meeple -> Meeple
f (MLock l) = let on = l ^. origNumeral
ps = s ^. stars
lo = MLock $ l & currNumeral .~ (on - ps)
in updateLockAni b lo
f m = m
----------
-- DRAW --
----------
drawStory :: Story -> Plane
drawStory s | isWinning s = let (SWon a) = s ^. status in fetchFrame a
| otherwise = drawScreen $ s ^. storyScreen
-----------------
-- SPAWN/ENTER --
-----------------
-- spawns inside a room. Set is "stars not to create, because already
-- taken".
spawn :: Room -> S.Set (Name, Coords) -> Screen
spawn r tcs = case findSpawn r of
Just cs -> let p = defaultPlayer cs
in thaw r tcs p
Nothing -> error $
"respawn: no spawn-point found in room \"" ++
r ^. title ++ "\"!"
enter :: Player -> S.Set (Title, Coords) -> Room -> Screen
enter p tcs r = ts
where
-- since every room has the same dimensions
-- mandatory coords
(mr, mc) = boundaries r
-- 'mirror' the overflown coordinate
(pr, pc) = p ^. position
-- north/south exit
nr | pr > mr = pr - mr
| pr < 1 = mr - pr
| otherwise = pr
-- west/east exit
nc | pc > mc = pc - mc
| pc < 1 = mc - pc
| otherwise = pc
p' = p & position .~ (nr, nc)
ts = thaw r tcs p'
thaw :: Room -> S.Set (Title, Coords) -> Player -> Screen
thaw r tcs p = defaultScreen
& room .~ r
& meeples .~ (r ^. frozenMeeples)
& meeples %~ filter notColl
& meeples %~ (MPlayer p :)
where
tcs' = S.filter ((== r ^. title) . fst) tcs
css = S.toList (S.map snd tcs')
notColl (MStar s) = notElem (s ^. position) css
notColl _ = True
-----------------
-- ANCILLARIES --
-----------------
-- checks if screens are sane (mandatory size)
-- returns ill ones
checkRoomSize :: Coords -> [Room] -> [(Title, Coords)]
checkRoomSize ms rs = rs ^.. (each . filtered ff . to bf)
where
-- filter function
ff r = r ^. to boundaries . to (/=ms)
-- return function
bf :: Room -> (Title, Coords)
bf r = (r ^. title, r ^. to boundaries)
-- for mismatch errors
mismErr :: Coords -> [(Title, Coords)] -> String
mismErr cs es =
"Found rooms of mismatched dimensions!\n" ++
"Expected dimension: " ++ dim2str cs ++ "\n" ++
"--\n" ++ unlines (map romErr es)
where
dim2str (wr, wc) = show wr ++ " rows, " ++ show wc ++ " cols."
romErr (t, wcs) = t ++ ": " ++ dim2str wcs