diff --git a/BearUI.hs b/BearUI.hs --- a/BearUI.hs +++ b/BearUI.hs @@ -1,6 +1,5 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} module BearUI where @@ -11,7 +10,9 @@ import qualified BearLibTerminal as B import BearLibTerminal.Keycodes () import qualified Data.Map.Strict as M +import qualified Data.Set as S +import CommonUI import CStyle import Geometry import Window @@ -46,6 +47,7 @@ B.TkSpace -> Just ' ' B.TkReturn -> Just '\r' B.TkEnter -> Just '\n' + B.TkClose -> Just 'q' c | B.TkA <= c && c <= B.TkZ -> Just $ chr (ord 'A' + (fromEnum c - fromEnum B.TkA)) B.Tk0 -> Just '0' c | B.Tk1 <= c && c <= B.Tk9 -> Just $ chr (ord '1' + (fromEnum c - fromEnum B.Tk1)) @@ -54,6 +56,9 @@ _ -> Nothing wSetStyle :: Window -> CStyle -> UIM () +wSetStyle _ (CStyle 7 False) = + -- special case: replace black on black with dim grey on black + liftIO $ B.terminalColorUInt 0xff282828 >> B.terminalBkColorUInt 0xff0000 wSetStyle _ (CStyle col b) = do let (bg,fg) = col `divMod` 8 liftIO . B.terminalColorUInt $ colour fg b @@ -78,27 +83,13 @@ 1 -> 0xffff0000 -- bold red 2 -> 0xff00ff00 -- bold green 3 -> 0xffffff00 -- bold yellow - 4 -> 0xff0000ff -- bold blue + 4 -> 0xff3030ff -- bold blue 5 -> 0xffff00bf -- bold magenta 6 -> 0xff00ffff -- bold cyan _ -> 0xff303030 -- dark grey withStyle :: Window -> CStyle -> (UIM a -> UIM a) withStyle w style m = wSetStyle w style >> (m <* wSetStyle w style0) -subCharAscii :: Bool -> Char -> Char -subCharAscii True = \case - '·' -> '+' - '┌' -> '+' - '┐' -> '+' - '└' -> '+' - '┘' -> '+' - '│' -> '|' - '║' -> '}' - '─' -> '-' - '═' -> '=' - c -> c -subCharAscii False = id - drawHighlightBoxChars :: CP.CPos -> [Glyph] -> UIM () drawHighlightBoxChars p gls = do let w = 2 + length gls @@ -107,15 +98,10 @@ withStyle TutorialWin (CStyle magenta True) . liftIO $ drawBorder sub (3,w) liftIO $ B.terminalLayer 0 where - -- Draw border manually rather than using C.wBorder: - -- default border characters are ugly on e.g. windows PuTTY, - -- and trying to set C.Border to use box-drawing chars doesn't work. drawBorder :: (Char -> Char) -> (Int,Int) -> IO () - drawBorder sub (h,w) = do - let add y x s = drawStrByChar (p' <> CP.CPos x y) $ sub <$> s - add 0 0 $ '╔':replicate (w-2) '═' <> "╗" - sequence_ [ add y' 0 "║" >> add y' (w-1) "║" | y' <- [1..h-2] ] - add (h-1) 0 $ '╚':replicate (w-2) '═' <> "╝" + drawBorder sub (h,w) = + drawBorderWith add w h + where add y x s = drawStrByChar (p' <> CP.CPos x y) $ sub <$> s p' = p <> CP.CPos (-1) (-1) @@ -137,6 +123,10 @@ let WinDim dx dy _ _ = getWin w withStyle w style . liftIO $ B.terminalPut (x+dx) (y+dy) (sub ch) +drawCompositeGlyph :: Window -> CP.CPos -> CompositeGlyph -> UIM () +drawCompositeGlyph w p gs = + mapM_ (drawGlyph w p) $ S.toList gs + erase :: UIM () erase = B.terminalClear @@ -147,10 +137,18 @@ wRefresh _ = liftIO B.terminalRefresh -- no per-win version +scrSize :: UIM (Int,Int) +scrSize = liftIO $ do + h <- B.terminalState B.TkHeight + w <- B.terminalState B.TkWidth + pure (h,w) + instance TM.TermM UIM where drawStr = drawStr drawGlyph = drawGlyph + drawCompositeGlyph = drawCompositeGlyph wErase = wErase wRefresh = wRefresh drawHighlightBoxChars = drawHighlightBoxChars asciiOnly = gets asciiOnly + isBear = pure True diff --git a/BearUIMInstance.hs b/BearUIMInstance.hs --- a/BearUIMInstance.hs +++ b/BearUIMInstance.hs @@ -10,11 +10,15 @@ import Control.Monad.State (evalStateT, liftIO, modify) import Data.Maybe (maybeToList) + import qualified BearLibTerminal as B import BearUI +import CStyle import Geometry +import Window +import qualified CPos as CP import qualified Game as G import qualified TermDraw as TD import qualified UIMonad as UIM @@ -22,25 +26,31 @@ instance UIM.UIMonad UIM where runUI m = evalStateT m nullUIState initUI = do - let wconf = "window: title='Fear of View', size=" <> show scrW <> "x" <> show scrH <> ";" + let wconf = "window: title='Fear of View', size=" <> show scrW <> "x" <> show scrH <> ", resizeable=true;" fconf = "font: VeraMoBd.ttf, size=15;" b1 <- liftIO B.terminalOpen b2 <- liftIO . B.terminalSetString $ wconf -- |Try to set font; uses default font if the font file isn't found. _ <- liftIO . B.terminalSetString $ fconf + liftIO $ B.terminalComposition B.CompositionOn pure $ b1 && b2 endUI = liftIO B.terminalClose - draw game = do + draw game = unlessSmall $ do + drawTrans erase drawState liftIO B.terminalRefresh where st = G.playState game - drawState = case st of - G.RoundEnded -> TD.drawMainScreen game - _ -> do - let bd = G.board game + drawTrans + | st == G.RoundEnded = pure () + | otherwise = do + wErase BoardWin forM_ (reverse $ G.transitions game) TD.drawTrans + drawState + | st == G.RoundEnded = TD.drawMainScreen game + | otherwise = do + let bd = G.board game TD.drawBoard bd TD.drawInv (G.selectedSlot game) (G.preserveSlots game) (G.canGrab game) (G.inventory game) (G.powerOn game) TD.drawEquip $ G.equipment game @@ -50,6 +60,16 @@ case st of G.Tutorialising b -> TD.highlightTut b _ -> pure () + unlessSmall m = do + (h,w) <- scrSize + if h < scrH || w < scrW then + let s = "Window too small!" + in if w < length s || h < 1 then pure () + else do + erase + drawStr StatusWin style0 (CP.CPos 0 0) s + wRefresh MainWin + else m suspend = pure () redraw = pure () setAsciiOnly a = modify $ \s -> s { asciiOnly = a } diff --git a/Board.hs b/Board.hs --- a/Board.hs +++ b/Board.hs @@ -1,8 +1,9 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} module Board where -import Control.Monad (foldM, guard, when) +import Control.Monad (filterM, foldM, guard, when, (<=<)) import Control.Monad.Random (Rand, StdGen) import Control.Monad.Writer (Writer, WriterT, lift, mapWriterT, runWriter, tell) @@ -10,15 +11,18 @@ import Data.Function (on) import Data.Functor (($>)) import Data.Functor.Identity (runIdentity) -import Data.Maybe (fromMaybe, mapMaybe) +import Data.Maybe (mapMaybe) import Data.Monoid (Any (..), Sum (..)) import Safe (atMay, headMay, minimumMay) import qualified Data.HashSet as HS +import qualified Data.List as L import qualified Data.Map.Strict as M +import qualified Data.Ord as O import qualified Data.Set as S import qualified BoardConf as BC +import qualified Fov as F import qualified Pos as P import qualified Power as Pow import qualified RollFrom as RF @@ -44,20 +48,26 @@ poss :: S.Set P.Pos poss = S.fromList [ P.Pos x y | x <- [0..w-1], y <- [0..h-1] ] -wPoss :: S.Set P.WPos -wPoss = S.fromList [ wp | p <- S.toList poss, up <- [True,False], let wp = P.WPos p up, all inBounds $ P.adjPoss wp ] - -boundaryWPoss :: S.Set P.WPos +wPoss, boundaryWPoss, wPossIncBdd :: S.Set P.WPos +wPoss = S.fromList $ + [ P.WPos (P.Pos x y) True | x <- [0..w-1], y <- [0..h-2] ] + <> [ P.WPos (P.Pos x y) False | x <- [0..w-2], y <- [0..h-1] ] +wPossIncBdd = S.fromList $ + [ P.WPos (P.Pos x y) True | x <- [0..w-1], y <- [-1..h-1] ] + <> [ P.WPos (P.Pos x y) False | x <- [-1..w-1], y <- [0..h-1] ] boundaryWPoss = S.fromList $ [ P.WPos (P.Pos x y) True | x <- [0..w-1], y <- [-1,h-1] ] <> [ P.WPos (P.Pos x y) False | x <- [-1,w-1], y <- [0..h-1] ] +maxFov :: F.Fov +maxFov = F.Fov poss wPossIncBdd + isBoundaryWPos :: P.WPos -> Bool isBoundaryWPos (P.WPos (P.Pos _ y) True) = y `elem` [-1,h-1] isBoundaryWPos (P.WPos (P.Pos x _) False) = x `elem` [-1,w-1] treasuresPerBoard :: Int -treasuresPerBoard = 5 +treasuresPerBoard = 4 -- XXX If all active, status line is 58 long -- watch out with renaming! data Status = Dazzled | Smoke | Haste | Ghost | Foresight deriving (Eq, Ord, Show) @@ -65,14 +75,14 @@ type Tagged = S.Set P.WPos data Board = Board - { visible :: S.Set P.Pos + { visible :: F.Fov , unrevealed :: S.Set P.Pos , creatures :: M.Map P.Pos Creature , items :: M.Map P.Pos Item , walls :: M.Map P.WPos Wall , exits :: M.Map P.WPos Exit , powers :: M.Map P.Pos Pow.Power - , treasures :: Int + , found :: [Item] , timer :: Int , possItems :: [Item] , safe :: Bool @@ -84,15 +94,15 @@ } new :: BC.BoardConf -> Board -new = Board S.empty poss M.empty M.empty M.empty initBoundary M.empty treasuresPerBoard 0 [] True M.empty M.empty S.empty M.empty where +new = Board F.empty poss M.empty M.empty M.empty initBoundary M.empty [] 0 [] True M.empty M.empty S.empty M.empty where initBoundary = M.fromSet (const UnseenBoundary) boundaryWPoss empty :: Board empty = new BC.emptyBoardConf -modVisible :: (S.Set P.Pos -> S.Set P.Pos) -> Board -> Board +modVisible :: (F.Fov -> F.Fov) -> Board -> Board modVisible f bd = bd { visible = f $ visible bd } -setVisible :: S.Set P.Pos -> Board -> Board +setVisible :: F.Fov -> Board -> Board setVisible = modVisible . const modUnrevealed :: (S.Set P.Pos -> S.Set P.Pos) -> Board -> Board @@ -115,12 +125,14 @@ modPowers :: (M.Map P.Pos Pow.Power -> M.Map P.Pos Pow.Power) -> Board -> Board modPowers f bd = bd { powers = f $ powers bd } -modTreasures, modTimer :: (Int -> Int) -> Board -> Board -modTreasures f bd = bd { treasures = f $ treasures bd } +modTimer :: (Int -> Int) -> Board -> Board modTimer f bd = bd { timer = f $ timer bd } setTimer :: Int -> Board -> Board setTimer = modTimer . const +modFound :: ([Item] -> [Item]) -> Board -> Board +modFound f bd = bd { found = f $ found bd } + setSafe :: Bool -> Board -> Board setSafe s bd = bd { safe = s } @@ -138,38 +150,70 @@ modConf :: (BC.BoardConf -> BC.BoardConf) -> Board -> Board modConf f bd = bd { conf = f $ conf bd } -wPosVisible :: S.Set P.Pos -> P.WPos -> Bool -wPosVisible vis wp = any (`S.member` vis) $ P.adjPoss wp +visibleBoundaryWPoss :: F.Fov -> S.Set P.WPos +visibleBoundaryWPoss = S.filter isBoundaryWPos . F.wpFov -visibleWPoss, invisibleWPoss :: Tagged -> S.Set P.Pos -> S.Set P.WPos -visibleWPoss tags vis = tags `S.union` S.filter (wPosVisible vis) wPoss -invisibleWPoss tags vis = S.filter (not . wPosVisible vis) wPoss S.\\ tags +visibleWPoss, invisibleWPoss :: Tagged -> F.Fov -> S.Set P.WPos +visibleWPoss tags vis = tags `S.union` S.filter (not . isBoundaryWPos) (F.wpFov vis) +invisibleWPoss tags vis = wPoss S.\\ visibleWPoss tags vis invisible :: Board -> S.Set P.Pos -invisible bd = poss S.\\ visible bd +invisible bd = poss S.\\ F.pFov (visible bd) -onSpawnTreasure :: Board -> Board -onSpawnTreasure bd = (if treasures bd > 1 then setUnrevealed poss else id) - $ modTreasures (+ (-1)) bd +treasuresLeft :: Board -> Int +treasuresLeft bd = treasuresPerBoard - length (found bd) -setPlayerDead :: Board -> Board -setPlayerDead = modCreatures . M.map $ \case - Player -> DeadPlayer - c -> c +onSpawnTreasure :: Item -> Board -> Board +onSpawnTreasure tr bd = (if treasuresLeft bd > 1 then setUnrevealed poss else id) + $ modFound (<>[tr]) bd +life :: Board -> Int +life bd + | (_, Player lf):_ <- players bd = lf + | otherwise = 0 + +modLife :: (Int -> Int) -> Board -> Board +modLife f = modCreatures . M.map $ \case + Player lf -> Player $ f lf + c -> c + +powerTypeAt :: P.Pos -> Pow.PowerType +powerTypeAt (P.Pos x y) + | 2*x > w = powerTypeAt (P.Pos (w-1-x) y) + | 2*y > h = powerTypeAt (P.Pos x (h-1-y)) +powerTypeAt (P.Pos 0 0) = Pow.Smoke +powerTypeAt (P.Pos 0 1) = Pow.Dazzle +powerTypeAt (P.Pos 0 2) = Pow.Teleport +powerTypeAt (P.Pos 1 0) = Pow.Ghost +powerTypeAt (P.Pos 1 1) = Pow.Heal +powerTypeAt (P.Pos 1 2) = Pow.Haste +powerTypeAt (P.Pos 2 0) = Pow.Teleport +powerTypeAt (P.Pos 2 1) = Pow.Foresight +powerTypeAt (P.Pos 2 2) = Pow.Undo +powerTypeAt _ = Pow.Heal -- impossible + +countPowers :: Board -> Int +countPowers b = sum $ Pow.maxCharges <$> M.elems (powers b) + treasureAt :: Board -> P.Pos -> Item -treasureAt bd (P.Pos x y) - | treasures bd == 1 = Gem +treasureAt bd p@(P.Pos x y) + | treasuresLeft bd == 1 = Gem $ powerTypeAt p | 2*x > w = treasureAt bd (P.Pos (w-1-x) y) | 2*y > h = treasureAt bd (P.Pos x (h-1-y)) treasureAt _ (P.Pos 2 2) = Junk treasureAt _ (P.Pos 1 1) = Potion -treasureAt _ (P.Pos 0 2) = MiniPotion treasureAt bd (P.Pos 1 0) | Just i <- headMay $ possItems bd = i treasureAt bd (P.Pos 0 y) | Just i <- possItems bd `atMay` (y+1) = i treasureAt bd (P.Pos 2 0) = treasureAt bd $ P.Pos 0 2 treasureAt _ _ = ScoreTreasure +sortOn' :: (a -> Int) -> [a] -> [a] +#if !MIN_VERSION_base(4,8,0) +sortOn' = L.sortOn +#else +sortOn' = L.sortBy . O.comparing +#endif + setFov :: Bool -> Board -> Rand StdGen Board setFov hasKey bd0 = setSafe False <$> iter bd0 where iter bd = @@ -182,9 +226,9 @@ else do bd' <- destroyInvisStuffs . updateVis . destroyInvisWalls . updateVis <$> createAtW (newWVis S.\\ oldWVis) bd - newVis' <- shuffle . S.toList $ visible bd' S.\\ oldVis - let newInvis' = S.toList $ oldVis S.\\ visible bd' - bd'' <- revealVis <$> (expectAtMaybe newInvis' =<< createAt newVis' bd') + newPVis' <- (sortOn' pdist <$>) . shuffle . S.toList . F.pFov $ visible bd' F.\\ oldVis + let newPInvis' = S.toList . F.pFov $ oldVis F.\\ visible bd' + bd'' <- revealVis <$> (expectAtMaybe newPInvis' =<< createAt newPVis' bd') -- created orbs may lead to new vision, so need to iterate iter bd'' destroyInvisWalls, destroyInvisStuffs :: Board -> Board @@ -206,8 +250,9 @@ createW :: Board -> P.WPos -> Rand StdGen Board createP bd p = modExpected (M.delete p) <$> createP' (modUnrevealed (S.delete p) bd) p createP' bd p - | S.null (unrevealed bd) && treasures bd > 0 = - pure . onSpawnTreasure . modItems (M.insert p $ treasureAt bd p) $ bd + | S.null (unrevealed bd) && treasuresLeft bd > 0 = + let treasure = treasureAt bd p + in pure . onSpawnTreasure treasure . modItems (M.insert p treasure) $ bd | safe bd = pure bd | p `M.member` creatures bd = pure bd | expectant bd = pure $ case expected bd M.!? p of @@ -215,88 +260,130 @@ _ -> bd | otherwise = maybe bd (($ bd) . modCreatures . M.insert p) <$> RF.roll (BC.creatureRoll bc) - createW bd wp = - maybe bd (($ bd) . modWalls . M.insert wp) <$> RF.roll (BC.wallRoll bc) + createW bd wp + | safe bd + , ppos:_ <- playerPoss bd + , wp `elem` (P.wposInDir ppos <$> P.dirs) = pure bd + | otherwise = + maybe bd (($ bd) . modWalls . M.insert wp) <$> RF.roll (BC.wallRoll bc) revealVis bd -- | Needed when all poss revealed on spawning treasure - | S.null (unrevealed bd) && treasures bd > 0 = setUnrevealed (poss `S.difference` visible bd) bd + | S.null (unrevealed bd) && treasuresLeft bd > 0 = setUnrevealed (poss `S.difference` visPs) bd -- | Needed only when we created a treasure - | otherwise = modUnrevealed (`S.difference` visible bd) bd + | otherwise = modUnrevealed (`S.difference` visPs) bd + where visPs = F.pFov $ visible bd + pdist :: P.Pos -> Int + pdist | ppos:_ <- playerPoss bd0 = P.distSquared ppos + | otherwise = const 0 seeBoundary :: Bool -> Board -> Rand StdGen Board seeBoundary hasKey bd = do v <- newVisBdd pure $ modExits (flip (foldr set) v) bd where - newVisBdd = shuffle . S.toList . S.filter (wPosVisible $ visible bd) . - S.filter ((== Just UnseenBoundary) . (exits bd M.!?)) $ boundaryWPoss + newVisBdd = (sortOn' (negate . pdist) <$>) . shuffle . S.toList + . S.filter ((== Just UnseenBoundary) . (exits bd M.!?)) . visibleBoundaryWPoss + $ visible bd set :: P.WPos -> M.Map P.WPos Exit -> M.Map P.WPos Exit set wp exs = M.insert wp ex exs where - ex | S.null . S.delete wp $ S.filter (sameWall wp) unseen = + ex | needKeyExit && S.size (S.map posOfBoundary $ S.delete wp unseen) == 1 = KeyExit True + | S.null . S.delete wp $ S.filter (sameWall wp) unseen = case S.toList $ S.filter (not . sameWall wp) unseen of - [] -> Exit - wp':_ | hasKey && all (sameWall wp') (S.delete wp unseen) -> KeyExit + [] -> Exit True + wp':_ | needKeyExit && all (sameWall wp') (S.delete wp unseen) -> KeyExit True _ -> SeenBoundary | otherwise = SeenBoundary unseen = S.filter ((== Just UnseenBoundary) . (exs M.!?)) boundaryWPoss sameWall = (==) `on` P.exitDir - + needKeyExit = hasKey && not (any (\case {KeyExit _ -> True; _ -> False}) $ M.elems exs) + posOfBoundary wp' = P.posInDir wp' (P.negDir $ P.exitDir wp') + pdist :: P.WPos -> Int + pdist | ppos:_ <- playerPoss bd = P.distSquaredToWPos ppos + | otherwise = const 0 -fov, playerFov :: Board -> S.Set P.Pos +fov, playerFov :: Board -> F.Fov fov bd = addOrbFovs plFov plFov where - plFov = fovs $ playerPoss bd <> cameraPoss bd - fovs = S.unions . map (fovAt bd) - addOrbFovs :: S.Set P.Pos -> S.Set P.Pos -> S.Set P.Pos + plFov = fovs (playerPoss bd <> cameraPoss bd) `F.union` ghostFovs + fovs = F.unions . map (fovAt bd) + addOrbFovs :: F.Fov -> F.Fov -> F.Fov addOrbFovs v news - | S.null news = v + | F.null news = v | otherwise = let - orbPoss = [ p | (p, i) <- M.assocs $ M.restrictKeys (items bd) news, isOrb i ] + orbPoss = [ p | (p, i) <- M.assocs . M.restrictKeys (items bd) $ F.pFov news, isOrb i ] + <> [ p | (p, c) <- M.assocs . M.restrictKeys (creatures bd) $ F.pFov news, isOrbMon c ] orbFovs = fovs orbPoss isOrb (ItemInvItem Orb) = True isOrb (RollingOrb _ _) = True isOrb _ = False - in addOrbFovs (v `S.union` orbFovs) (orbFovs S.\\ v) -playerFov bd = S.unions . map (fovAt bd) $ playerPoss bd + isOrbMon (SmartMonster True) = True + isOrbMon _ = False + in addOrbFovs (v `F.union` orbFovs) (orbFovs F.\\ v) + -- We can see upgraded ghosts through walls + ghostPoss | ppos:_ <- playerPoss bd + = S.filter ((<= 2) . P.distSquared ppos) . M.keysSet . M.filter (== GhostMonster True) $ creatures bd + | otherwise = S.empty + ghostFovs = F.Fov ghostPoss S.empty +playerFov bd = F.unions . map (fovAt bd) $ playerPoss bd playerPoss :: Board -> [ P.Pos ] -playerPoss bd = [ p | (p,Player) <- M.assocs $ creatures bd ] +playerPoss bd = [ p | (p,c) <- M.assocs $ creatures bd, isPlayer c ] +players :: Board -> [ (P.Pos, Creature) ] +players bd = filter (isPlayer . snd) . M.assocs $ creatures bd + cameraPoss :: Board -> [ P.Pos ] cameraPoss bd = [ p | (p, ItemInvItem (Camera _)) <- M.assocs $ items bd ] -fovAt :: Board -> P.Pos -> S.Set P.Pos -fovAt bd base = S.filter inRange $ poss S.\\ blocked where - blocked = S.unions [ wallCone (short wl) base wp +fovAt :: Board -> P.Pos -> F.Fov +fovAt bd base = F.filter pInRange wpInRange $ maxFov F.\\ blocked where + blocked = F.unions [ wallCone (short wl) base wp | (wp,wl) <- M.assocs $ walls bd, wl `notElem` [Window, BrokenWindow] ] where short Pillar = True short (UmbrellaWall _) = True short _ = False - inRange + pInRange | Just r <- sightRadius = (<= r*r) . ((smokeFac*smokeFac)*) . P.distSquared base | otherwise = const True + wpInRange + | Just r <- sightRadius = (<= 2*r*2*r) . ((smokeFac*smokeFac)*) . P.distSquaredToWPos base + | otherwise = const True + sightRadius = minimumMay $ mapMaybe rad (M.assocs (statuses bd)) where - sightRadius = minimumMay $ mapMaybe rad (M.assocs (statuses bd)) - rad (Dazzled,_) = Just 0 + rad (Dazzled,_) = Just $ smokeFac `div` 2 rad (Smoke,n) = Just $ max 0 (maxSmoke - n) + smokeFac rad _ = Nothing -wallCone :: Bool -> P.Pos -> P.WPos -> S.Set P.Pos -wallCone short base wp = (poss `S.intersection`) $ (base +^) `S.map` wallCone' (neg base +^ wp) where - wallCone' (P.WPos p False) = flipPos `S.map` wallCone' (P.WPos (flipPos p) True) +wallCone :: Bool -> P.Pos -> P.WPos -> F.Fov +wallCone short base wp = maxFov `F.intersection` + (F.rebase base . wallCone' $ neg base +^ wp) + where + wallCone' :: P.WPos -> F.Fov + wallCone' (P.WPos p False) = F.map flipPos flipWPos $ wallCone' (P.WPos (flipPos p) True) wallCone' (P.WPos (P.Pos x y) True) - | x < 0 = (\(P.Pos x' y') -> P.Pos (-x') y') `S.map` wallCone' (P.WPos (P.Pos (-x) y) True) - | y < 0 = (\(P.Pos x' y') -> P.Pos x' (-y')) `S.map` wallCone' (P.WPos (P.Pos x (-y-1)) True) - | otherwise = - S.fromList [ P.Pos x' y' + | x < 0 = F.map reflxPos reflxWPos $ wallCone' (P.WPos (P.Pos (-x) y) True) + | y < 0 = F.map reflyPos reflyWPos $ wallCone' (P.WPos (P.Pos x (-y-1)) True) + | otherwise = F.Fov coneP coneWP + where + -- (y+1/2)/(x-w/2) <= y'/x' <= (y+1/2)/(x+w/2) + ineq x' y' | short = abs (x'*(8*y+4) - 8*y'*x) <= 3*y' -- w = 3/4 + | otherwise = abs (x'*(2*y+1) - 2*y'*x) <= y' -- w = 1 + coneP = S.fromList [ P.Pos x' y' | x' <- [-w..w], y' <- [y+1..h] , ineq x' y' - ] where - -- (y+1/2)/(x-w/2) <= y'/x' <= (y+1/2)/(x+w/2) - ineq x' y' | short = abs (x'*(8*y+4) - 8*y'*x) <= 3*y' -- w = 3/4 - | otherwise = abs (x'*(2*y+1) - 2*y'*x) <= y' -- w = 1 + ] + coneWP = S.fromList [ P.WPos (P.Pos x' y') up + | x' <- [-w..w], y' <- [y+1..h] + , up <- [False, True] + , if up then ineq (2*x') (2*y' + 1) else ineq (2*x' + 1) (2*y') + ] flipPos (P.Pos x y) = P.Pos y x + flipWPos (P.WPos p up) = P.WPos (flipPos p) (not up) + reflxPos (P.Pos x y) = P.Pos (-x) y + reflyPos (P.Pos x y) = P.Pos x (-y) + reflxWPos (P.WPos p up) = P.WPos ((if up then id else (+^ P.dirPos P.DLeft)) $ reflxPos p) up + reflyWPos (P.WPos p up) = P.WPos ((if not up then id else (+^ P.dirPos P.DDown)) $ reflyPos p) up smokeFac, maxSmoke :: Int smokeFac = 4 @@ -309,6 +396,7 @@ data Alert = AlertMoveCreature Creature P.Pos P.Dir + | AlertMoveCreatureVia Creature P.Pos | AlertMoveItem Item P.Pos P.Dir | AlertUseItem Item P.Pos P.Dir | AlertHighlight (S.Set P.Pos) (S.Set P.WPos) @@ -316,14 +404,15 @@ data MoveResults = MoveResults { damage :: Sum Int - , exitings :: [P.WPos] + , exitings :: [(Creature, P.WPos)] + , alarmings :: [P.Dir] , alerts :: [Alert] , someAction :: Any } instance Semigroup MoveResults where - MoveResults a b c d <> MoveResults a' b' c' d' = MoveResults (a<>a') (b<>b') (c<>c') (d<>d') + MoveResults a b c d e <> MoveResults a' b' c' d' e' = MoveResults (a<>a') (b<>b') (c<>c') (d<>d') (e<>e') instance Monoid MoveResults where - mempty = MoveResults mempty mempty mempty mempty + mempty = MoveResults mempty mempty mempty mempty mempty action :: MoveResults action = mempty { someAction = Any True } @@ -332,35 +421,41 @@ throughWall :: Board -> Creature -> Maybe Wall -> Bool throughWall _ _ Nothing = True -throughWall _ GhostMonster _ = True -throughWall bd Player _ | ghostly bd = True -throughWall _ Player (Just Hedge) = True +throughWall _ (GhostMonster _) _ = True +throughWall bd (Player _) _ | ghostly bd = True +throughWall _ (Player _) (Just Hedge) = True throughWall _ (InflatedBalloon _) (Just _) = False throughWall _ _ (Just BrokenWindow) = True throughWall _ _ _ = False +canReachThrough :: Board -> P.WPos -> Bool +canReachThrough bd wp = (walls bd M.!? wp) `elem` [Nothing, Just BrokenWindow] + creatureCanMove :: Board -> Creature -> P.Pos -> P.Dir -> Bool creatureCanMove bd c p dir = let p' = P.dirPos dir +^ p wp = P.wposInDir p dir - in inBounds p' && (c == Player || M.notMember p' (creatures bd)) && throughWall bd c (walls bd M.!? wp) + in inBounds p' && (isPlayer c || M.notMember p' (creatures bd)) && throughWall bd c (walls bd M.!? wp) creatureCanTryMove :: Board -> Creature -> P.Pos -> P.Dir -> Bool creatureCanTryMove bd c p dir = let p' = P.dirPos dir +^ p wp = P.wposInDir p dir + isSmart (SmartMonster _) = True + isSmart _ = False in and [ inBounds p' - , creatures bd M.!? p' `elem` [Nothing, Just Player] + , maybe True isPlayer $ creatures bd M.!? p' , throughWall bd c $ walls bd M.!? wp - , c /= SmartMonster || p' `S.member` playerFov bd + , not (isSmart c) || p' `S.member` F.pFov (playerFov bd) ] -exitInDir :: Board -> P.Pos -> P.Dir -> Bool -exitInDir bd p d = exits bd M.!? P.wposInDir p d `elem` [Just Exit, Just KeyExit] - -enterAt :: P.WPos -> Board -> Board -enterAt wp@(P.WPos (P.Pos x y) _) = modVisible (S.insert p') . modCreatures (M.insert p' Player) . modExits (M.insert wp Entrance) where +enterAt :: Int -> P.WPos -> Board -> Board +enterAt lf wp@(P.WPos (P.Pos x y) _) = + modVisible (F.insertP p') + . modCreatures (M.insert p' (Player lf)) + . modExits (M.insert wp Entrance) + where p' = P.Pos (max 0 x) (max 0 y) oppositeWPos :: P.WPos -> P.WPos @@ -369,9 +464,8 @@ tryMoveCreature :: P.Dir -> P.Pos -> Board -> Writer MoveResults Board tryMoveCreature dir p bd - | Just Player <- creatures bd M.!? p + | Just (Player _) <- creatures bd M.!? p , not $ ghostly bd - , let wp = P.wposInDir p dir , Just wl <- walls bd M.!? wp , Just cost <- wallDestructionCost wl = do @@ -380,13 +474,13 @@ | Just c <- creatures bd M.!? p, creatureCanMove bd c p dir = do let p' = P.dirPos dir +^ p bd' <- case creatures bd M.!? p' of - Just (InflatedBalloon _) | c == Player -> + Just (InflatedBalloon _) | isPlayer c -> tryMoveCreature dir p' bd _ -> pure bd - let creatureDestroyed = maybe False isMonster $ creatures bd' M.!? p' - throughPainful = c == Player && not (ghostly bd) && - (walls bd M.!? P.wposInDir p dir) `elem` [Just Hedge, Just BrokenWindow] - dmg = sum $ [2 | creatureDestroyed] <> [1 | throughPainful] + let creatureDamage = maybe 0 monsterDamage $ creatures bd' M.!? p' + throughPainful = isPlayer c && not (ghostly bd) && + (walls bd M.!? wp) `elem` [Just Hedge, Just BrokenWindow] + dmg = creatureDamage + sum [1 | throughPainful] modMove = modCreatures $ M.insert p' c . M.delete p modBalloon | Just (InflatedBalloon charges) <- creatures bd' M.!? p' @@ -396,16 +490,29 @@ | otherwise = id tell $ action { damage = Sum dmg, alerts = move c } pure . modBalloon . modMove $ bd' - | Just Player <- creatures bd M.!? p, exitInDir bd p dir = do - tell $ action { exitings = [P.wposInDir p dir], alerts = move Player } - pure $ modCreatures (M.delete p) bd + | Just c@(Player _) <- creatures bd M.!? p + , Just e <- exits bd M.!? wp = case e of + Exit True -> breakExit Exit + KeyExit True -> breakExit KeyExit + Exit False -> leave c + KeyExit False -> leave c + _ -> pure bd | otherwise = pure bd where + wp = P.wposInDir p dir move c = [AlertMoveCreature c p dir] damageWall = \case ThickHedge -> Just Hedge Window -> Just BrokenWindow _ -> Nothing + breakExit :: (Bool -> Exit) -> Writer MoveResults Board + breakExit etp = do + tell action { alarmings = [dir] } + pure . modConf (BC.apply (diffs bd) dir) $ modExits (M.insert wp $ etp False) bd + leave :: Creature -> Writer MoveResults Board + leave c = do + tell $ action { exitings = [(c, wp)], alerts = move c } + pure $ modCreatures (M.delete p) bd collectItems :: Board -> Writer [Item] Board collectItems bd @@ -417,12 +524,12 @@ collectItemsAt p bd | Just item <- items bd M.!? p = let takeUmbrella - | UmbrellaHandle d <- item = + | UmbrellaHandle d _ <- item = let wp' = P.wposInDir p d in modTagged (S.delete wp') . modWalls (M.delete wp') | otherwise = id getItem - | UmbrellaHandle d <- item = P.wposInDir p d `M.member` walls bd + | UmbrellaHandle d _ <- item = P.wposInDir p d `M.member` walls bd | otherwise = True in do when getItem $ tell [item] @@ -432,7 +539,15 @@ grabItem :: P.Dir -> Board -> Writer [Item] Board grabItem d bd | p:_ <- playerPoss bd - = collectItemsAt (p +^ P.dirPos d) bd + , canReachThrough bd $ P.wposInDir p d + , let p' = p +^ P.dirPos d + , Just item <- items bd M.!? p' + , case item of + RollingOrb _ _ -> False + Gem _ -> False + ItemInvItem (Camera _) -> False + _ -> True + = collectItemsAt p' bd | otherwise = pure bd @@ -451,24 +566,32 @@ in headMay . concat <$> mapM shuffle dirs npcs :: Board -> M.Map P.Pos Creature -npcs = M.filter (/= Player) . creatures +npcs = M.filter (not . isPlayer) . creatures incStatus :: Status -> Int -> Board -> Board incStatus st n = modStatuses $ M.alter f st where f (Just n') = Just $ n + n' f _ = Just n -hasted,isHasteRound,ghostly,expectant :: Board -> Bool +hasted,isHasteRound,ghostly,expectant,preexpectant :: Board -> Bool hasted = M.member Haste . statuses ghostly = M.member Ghost . statuses expectant = M.member Foresight . statuses +-- |preexpectant -- will we be expectant after moving? +preexpectant bd + | Just n <- statuses bd M.!? Foresight = n > 0 || isHasteRound bd + | otherwise = False isHasteRound bd | Just n <- statuses bd M.!? Haste = n `mod` 2 == 1 | otherwise = False -beginExpect :: Board -> Rand StdGen Board +beginExpect, reExpect, expectAll :: Board -> Rand StdGen Board beginExpect bd | expectant bd = pure bd - | otherwise = (expectAt . S.toList $ invisible bd) bd + | otherwise = expectAll bd +reExpect bd + | not $ expectant bd = pure bd + | otherwise = expectAll bd +expectAll bd = (expectAt . S.toList $ invisible bd) bd expectAt :: [P.Pos] -> Board -> Rand StdGen Board expectAt ps bd0 = foldM expectP bd0 ps @@ -477,11 +600,19 @@ npcsAct :: Board -> WriterT [Alert] (Rand StdGen) Board npcsAct bd0 - | isHasteRound bd0 = pure bd0 + | isHasteRound bd0 = do + foldM npcAct bd0 =<< getActorsWith isFast bd0 | otherwise = do - actors <- lift . shuffle . M.toList $ npcs bd0 - foldM npcAct bd0 actors + bd' <- foldM npcAct bd0 =<< getActors bd0 + (if hasted bd0 then pure else actAlerted isFast) bd' >>= actAlerted isVeryFast where + getActors :: Board -> WriterT [Alert] (Rand StdGen) [(P.Pos, Creature)] + getActors = lift . shuffle . M.toList . npcs + getActorsWith :: (Creature -> Rand StdGen Bool) -> Board -> WriterT [Alert] (Rand StdGen) [(P.Pos, Creature)] + getActorsWith f = filterM (lift . f . snd) <=< getActors + actAlerted f bd = do + actors <- getActorsWith f bd + foldM npcAct bd actors <* mapM_ (tell . (\(p,c) -> [AlertMoveCreatureVia c p])) actors npcAct :: Board -> (P.Pos, Creature) -> WriterT [Alert] (Rand StdGen) Board npcAct bd (p,c) | ppos:_ <- playerPoss bd = @@ -491,44 +622,60 @@ _ -> pure bd | otherwise = pure bd where - -- Force non-calm monsters to move randomly when next to player + -- Force non-calm monsters to move randomly when next to player; + -- forced moves ignore powers of GhostMonster and SmartMonster, + -- though SmartMonster still avoids moving into sight when possible. forceRand :: Maybe P.Dir -> WriterT [Alert] (Rand StdGen) (Maybe P.Dir) - forceRand md | c `elem` [ CalmMonster, GhostMonster ] = pure md + forceRand md | CalmMonster _ <- c = pure md forceRand (Just dir) | not (creatureCanMove bd c p dir) = randAvailableDir - forceRand Nothing | c == SmartMonster = randAvailableDir + forceRand Nothing | SmartMonster _ <- c = randAvailableDir forceRand md = pure md - randAvailableDir = lift . randElem $ - filter (\d -> creatureCanMove bd c p d && creatureCanTryMove bd c p d) P.dirs + randAvailableDir + | SmartMonster _ <- c, not $ null smartDirs = lift $ randElem smartDirs + | otherwise = lift $ randElem availableDirs + availableDirs = filter (\d -> creatureCanMove bd BasicMonster p d && creatureCanTryMove bd BasicMonster p d) P.dirs + smartDirs = filter (\d -> (p +^ P.dirPos d) `S.member` F.pFov (playerFov bd)) availableDirs - pathAlg BasicMonster = chaseDir - pathAlg CalmMonster = chaseDir - pathAlg GhostMonster = chaseDir - pathAlg SmartMonster = findPathDir - pathAlg ChaseMonster = findPathDir - pathAlg _ = \_ _ _ _ -> pure Nothing + pathAlg BasicMonster = chaseDir + pathAlg (CalmMonster _) = chaseDir + pathAlg (GhostMonster _) = chaseDir + pathAlg (FastMonster _) = chaseDir + pathAlg (SmartMonster _) = findPathDir + pathAlg _ = \_ _ _ _ -> pure Nothing + + isFast, isVeryFast :: Creature -> Rand StdGen Bool + isFast (FastMonster False) = pure True + isFast (FastMonster True) = randElemUnsafe [True, True, False] + isFast _ = pure False + isVeryFast (FastMonster True) = randElemUnsafe [True, False] + isVeryFast _ = pure False + tryUseInvItem :: InvItem -> P.Dir -> Board -> WriterT [Alert] Maybe Board tryUseInvItem e d bd - | p:_ <- playerPoss bd = do + | (p,plc):_ <- players bd = do tell [AlertUseItem (ItemInvItem e) p d] let wp = P.wposInDir p d - lift . guard $ canUseOnWall e || (walls bd M.!? wp) `elem` [Nothing, Just BrokenWindow] + lift . guard $ canUseOnWall e || canReachThrough bd wp let p' = p +^ P.dirPos d lift . guard $ inBounds p' case e of Cloak -> pure $ modWalls (M.insert wp $ CloakWall d 1) bd - Umbrella -> do + Umbrella charges -> do guard . M.notMember p' $ items bd let wp' = P.wposInDir p' d - guard $ inBoundsW wp' - guard $ (walls bd M.!? wp') `elem` [Nothing, Just BrokenWindow] + guard $ inBoundsW wp' && canReachThrough bd wp' let addUmbrellaWall = modWalls (M.insert wp' $ UmbrellaWall d) if p' `M.member` creatures bd then do let (bd', mr) = runWriter $ tryMoveCreature d p' bd guard . getAny $ someAction mr pure $ addUmbrellaWall bd' - else pure . modItems (M.insert p' $ UmbrellaHandle d) . addUmbrellaWall $ bd + else pure + . (if charges > 1 + then modItems (M.insert p' . UmbrellaHandle d $ charges - 1) + else id) + . addUmbrellaWall $ bd Balloon charges -> let inflate = modCreatures (M.insert p' (InflatedBalloon $ charges - 1)) in if p' `M.member` creatures bd then do @@ -538,29 +685,34 @@ else pure $ inflate bd Orb -> ($ bd) <$> dropItem p' (RollingOrb d True) Flash -> - let flashPoss = wallCone True p wp - flashWPoss = wp `S.insert` invisibleWPoss S.empty (poss S.\\ flashPoss) + let flashFov = wallCone True p wp + flashPoss = F.pFov flashFov + flashWPoss = wp `S.insert` F.wpFov flashFov delPoss = flip (foldr M.delete) flashPoss delWPoss = flip (foldr M.delete) flashWPoss delWPossS = flip (foldr S.delete) flashWPoss + newUnrevealed bd' = unrevealed bd' `S.difference` flashPoss reveal, destroyTreasure :: Board -> Board - reveal = destroyTreasure - . modUnrevealed (`S.difference` flashPoss) - . modVisible (`S.union` flashPoss) - -- | Pretend we created and immediately destroyed a treasure - destroyTreasure bd' | null (unrevealed bd') = onSpawnTreasure bd' + reveal = modUnrevealed (`S.difference` flashPoss) . destroyTreasure . modVisible (`F.union` flashFov) + -- | Pretend we created and immediately destroyed a treasure on flashing all unrevealed + destroyTreasure bd' + | null $ newUnrevealed bd' + , trPos:_ <- sortOn' (negate . P.distSquared p) . S.toList $ unrevealed bd' + = onSpawnTreasure (treasureAt bd' trPos) bd' | otherwise = bd' in tell [AlertHighlight flashPoss flashWPoss] $> (reveal . modItems delPoss . modCreatures delPoss . modTagged delWPossS $ modWalls delWPoss bd) Tent -> do guard . M.notMember p' $ creatures bd pure . - modWalls (flip (foldr (M.alter (Just . fromMaybe TentWall))) (filter inBoundsW $ P.wposInDir p' <$> P.dirs)) - . modCreatures (M.delete p . M.insert p' Player) $ bd + modWalls (flip (foldr (`M.insert` TentWall)) (filter inBoundsW $ P.wposInDir p' <$> P.dirs)) + . modCreatures (M.delete p . M.insert p' plc) $ bd Spraypaint _ -> do guard $ wp `M.member` walls bd pure $ modTagged (S.insert wp) bd - _ -> ($ bd) <$> dropItem p' (ItemInvItem e) + Camera _ -> -- handled in Game + pure bd + -- _ -> ($ bd) <$> dropItem p' (ItemInvItem e) | otherwise = lift Nothing where dropItem p i = do @@ -582,9 +734,8 @@ . tickTimer <$> rollOrbs bd0 where - decayCloaks bd = foldr decayCloakWall bd . M.assocs . M.filter isCloakWall $ walls bd - isCloakWall (CloakWall _ _) = True - isCloakWall _ = False + decayCloaks bd = foldr decayCloakWall bd . M.assocs + . M.filter (\case {CloakWall _ _ -> True; _ -> False}) $ walls bd decayCloakWall :: (P.WPos, Wall) -> Board -> Board decayCloakWall (wp, CloakWall d n) | n > 0 = modWalls . M.insert wp $ CloakWall d (n-1) @@ -596,10 +747,12 @@ ItemInvItem (Camera n) | n > 0 -> Just . ItemInvItem . Camera $ n-1 | otherwise -> Nothing i -> Just i - decayStatuses hasteOnly = M.filter (>0) . M.mapWithKey decay where + decayStatuses hasteOnly = M.filterWithKey active . M.mapWithKey decay where decay Haste n = n-1 decay _ n | hasteOnly = n decay _ n = n-1 + active Foresight n = n >= 0 + active _ n = n > 0 rollOrbs bd = foldM rollOrb bd (M.assocs $ items bd) where rollOrb :: Board -> (P.Pos, Item) -> Writer [Alert] Board rollOrb bd' (p, RollingOrb dir True) @@ -615,28 +768,24 @@ rollOrb bd' _ = pure bd' tickTimer = rollOver . modTimer (+1) where rollOver bd | timer bd >= turnsPerSide - = modConf (BC.modRolls decSides decSides) . setTimer 0 $ bd + = modConf (BC.modRolls id decSides) . setTimer 0 $ bd rollOver bd = bd - decSides = RF.modSides (+ (-1)) - turnsPerSide = 8 + decSides = RF.modSides (max 1 . (+ (-1))) + turnsPerSide = 10 addPower :: Bool -> Board -> Board addPower overUsable bd | p:_ <- playerPoss bd = modPowers (M.alter (add p) p) bd | otherwise = bd where - add p Nothing = Just . Pow.upgrade $ Pow.new (typeAt p) overUsable + add p Nothing = Just . Pow.upgrade $ Pow.new (powerTypeAt p) overUsable add _ (Just pow) = Just $ Pow.upgrade pow - typeAt (P.Pos x y) - | 2*x > w = typeAt (P.Pos (w-1-x) y) - | 2*y > h = typeAt (P.Pos x (h-1-y)) - typeAt (P.Pos 0 0) = Pow.Smoke - typeAt (P.Pos 0 1) = Pow.Dazzle - typeAt (P.Pos 0 2) = Pow.Teleport - typeAt (P.Pos 1 0) = Pow.Ghost - typeAt (P.Pos 1 1) = Pow.Heal - typeAt (P.Pos 1 2) = Pow.Haste - typeAt (P.Pos 2 0) = Pow.Teleport - typeAt (P.Pos 2 1) = Pow.Foresight - typeAt (P.Pos 2 2) = Pow.Undo - typeAt _ = Pow.Heal -- impossible + +canUndo :: Board -> Bool +canUndo bd + | Just (Player _) <- creatures bd M.!? undoPos + , Just pow <- powers bd M.!? undoPos + = Pow.activatableTimes pow > 0 + | otherwise = False + where + undoPos = P.Pos 2 2 diff --git a/BoardConf.hs b/BoardConf.hs --- a/BoardConf.hs +++ b/BoardConf.hs @@ -51,23 +51,19 @@ genDiffs :: BoardConf -> Rand StdGen BoardConfDiffs genDiffs bc = (M.fromList <$>) . forM P.dirs $ \d -> (d,) <$> genDiffDir d where - genDiffDir P.DUp = sequence [ addCreature, swapCreature ] - genDiffDir P.DRight = sequence [ addCreature, swapWall ] - genDiffDir P.DDown = sequence [ addWall, swapWall ] - genDiffDir P.DLeft = sequence [ addWall, swapCreature ] - addCreature = pure . Add $ DiffableCreature BasicMonster + genDiffDir d = sequence [ doCreature $ dirCTp d, doWall ] + dirCTp P.DUp = SmartMonster + dirCTp P.DDown = CalmMonster + dirCTp P.DLeft = GhostMonster + dirCTp P.DRight = FastMonster + doCreature :: (Bool -> Creature) -> Rand StdGen (RollFromDiff Diffable) + doCreature cTp = randElemUnsafe $ + [ Add . DiffableCreature $ cTp False ] <> + [ Swap (DiffableCreature $ cTp False) (DiffableCreature $ cTp True) + | (2 <=) . length . filter (== cTp False) $ RF.vals (creatureRoll bc) + ] + doWall = join $ randElemUnsafe [ addWall, swapWall ] addWall = pure . Add . DiffableWall $ if level bc == 1 then Hedge else BasicWall - swapCreature = do - swapOut <- randElem . filter upgradableCreature $ RF.vals (creatureRoll bc) - case swapOut of - Nothing -> addCreature - Just c -> Swap (DiffableCreature c) . DiffableCreature <$> upgradeCreature c - creatureUpgrades BasicMonster = [CalmMonster, ChaseMonster] - creatureUpgrades CalmMonster = [GhostMonster] - creatureUpgrades ChaseMonster = [SmartMonster] - creatureUpgrades _ = [] - upgradableCreature = not . null . creatureUpgrades - upgradeCreature = randElemUnsafe . creatureUpgrades swapWall = do swapOut <- randElem . filter upgradableWall $ RF.vals (wallRoll bc) case swapOut of diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -9,3 +9,25 @@ ## 0.1.1.0 -- 2025-08-15 * Add bearlibterminal-based UI (enabled with -fbear) + +## 0.2.0.0 -- 2026-08-08 +* Rework monsters: 4 monster types, each with upgrade +* Rework vision: visibility of walls independent of tiles +* Increase difficulty on breaking exit seal rather than on leaving +* Increase only wall density over time within a round +* Uncover seen tiles and exits in order of distance, increasing predictability +* Increase life to 7 +* Reduce treasures per round +* Reduce equipment junk costs +* Preserve status effects across levels of a round +* Remove minipotions +* Leave Camera in current location on use +* Limit Umbrella to 8 uses +* Rename GrabHand to Hook; disallow hooking placed cameras and rolling orbs +* Allow use of Undo after death +* Prevent spawning walls next to player on entry and teleport +* Ensure key exit doesn't spawn by same tile as main exit +* Use more box-drawing characters for prettiness +* List treasures found in a level +* Include number of gems collected in highscore entry +* Show average score over last 10 games diff --git a/CStyle.hs b/CStyle.hs --- a/CStyle.hs +++ b/CStyle.hs @@ -1,5 +1,7 @@ module CStyle where +import qualified Data.Set as S + type ColPair = Int white,red,green,yellow,blue,magenta,cyan,black :: ColPair white = 0 @@ -11,17 +13,24 @@ cyan = 6 black = 7 -onBlue, onRed, onYellow :: ColPair -> ColPair +onBlue, onRed, onMagenta :: ColPair -> ColPair onBlue = (+8) . (`mod` 8) onRed = (+16) . (`mod` 8) -onYellow = (+24) . (`mod` 8) +onMagenta = (+24) . (`mod` 8) data CStyle = CStyle { cstyleCol :: ColPair, cstyleBold :: Bool } + deriving (Eq, Ord) style0, styleBold :: CStyle style0 = CStyle 0 False styleBold = CStyle 0 True data Glyph = Glyph { glyphChar :: Char, glyphStyle :: CStyle } + deriving (Eq, Ord) +modStyleColour :: (ColPair -> ColPair) -> CStyle -> CStyle +modStyleColour f (CStyle col b) = CStyle (f col) b + modColour :: (ColPair -> ColPair) -> Glyph -> Glyph -modColour f (Glyph c (CStyle col b)) = Glyph c (CStyle (f col) b) +modColour f (Glyph c st) = Glyph c $ modStyleColour f st + +type CompositeGlyph = S.Set Glyph diff --git a/Command.hs b/Command.hs --- a/Command.hs +++ b/Command.hs @@ -9,8 +9,8 @@ | UsePower | Accept | SkipTutorial - | DebugAddPower | DebugAddJunk | DebugAddItems | DebugExit - | ToggleAscii + | DebugAddPower | DebugAddJunk | DebugAddItems | DebugExit | DebugAlarm | DebugWait + | ToggleAscii | ToggleShowRecentHS | Refresh | Redraw | Suspend | Clear | Quit | ForceQuit deriving (Eq, Ord, Show, Read) diff --git a/CommonUI.hs b/CommonUI.hs new file mode 100644 --- /dev/null +++ b/CommonUI.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE LambdaCase #-} + +module CommonUI where + +subCharAscii :: Bool -> Char -> Char +subCharAscii True = \case + c | c `elem` "·┌┐└┘┼├┬┤┴╷╴╵╶" -> '+' + '│' -> '|' + '║' -> '}' + '─' -> '-' + '═' -> '=' + c -> c +subCharAscii False = id + +drawBorderWith :: (Int -> Int -> String -> IO ()) -> Int -> Int -> IO () +drawBorderWith add w h = do + add 0 0 $ '┌':replicate (w-2) '─' <> "┐" + sequence_ [ add y' 0 "│" >> add y' (w-1) "│" + | y' <- [1..h-2] ] + add (h-1) 0 ('└':replicate (w-2) '─' <> "┘") diff --git a/Creature.hs b/Creature.hs --- a/Creature.hs +++ b/Creature.hs @@ -1,22 +1,27 @@ module Creature where data Creature - = Player - | DeadPlayer - | SmartMonster - | GhostMonster - | ChaseMonster - | CalmMonster + = Player Int + | SmartMonster Bool + | FastMonster Bool + | CalmMonster Bool + | GhostMonster Bool | BasicMonster | InflatedBalloon Int deriving (Eq, Ord) -isMonster :: Creature -> Bool -isMonster Player = False -isMonster DeadPlayer = False +isMonster, isPlayer :: Creature -> Bool +isMonster (Player _) = False isMonster (InflatedBalloon _) = False -isMonster SmartMonster = True -isMonster GhostMonster = True -isMonster ChaseMonster = True -isMonster CalmMonster = True +isMonster (SmartMonster _) = True +isMonster (FastMonster _) = True +isMonster (CalmMonster _) = True +isMonster (GhostMonster _) = True isMonster BasicMonster = True +isPlayer (Player _) = True +isPlayer _ = False + +monsterDamage :: Creature -> Int +monsterDamage (CalmMonster False) = 1 +monsterDamage m | isMonster m = 2 +monsterDamage _ = 0 diff --git a/CursesUI.hs b/CursesUI.hs --- a/CursesUI.hs +++ b/CursesUI.hs @@ -1,17 +1,20 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} module CursesUI where import Control.Exception.Safe import Control.Monad.State import Data.Char (chr) +import Data.Function (on) +import Data.List (minimumBy) import Foreign.Ptr import qualified Data.Map.Strict as M +import qualified Data.Set as S import qualified UI.HSCurses.Curses as C +import CommonUI import CStyle import Window @@ -107,20 +110,6 @@ withStyle :: Window -> CStyle -> (UIM a -> UIM a) withStyle w style m = wSetStyle w style >> (m <* wSetStyle w style0) -subCharAscii :: Bool -> Char -> Char -subCharAscii True = \case - '·' -> '+' - '┌' -> '+' - '┐' -> '+' - '└' -> '+' - '┘' -> '+' - '│' -> '|' - '║' -> '}' - '─' -> '-' - '═' -> '=' - c -> c -subCharAscii False = id - drawHighlightBoxChars :: CP.CPos -> [Glyph] -> UIM () drawHighlightBoxChars (CP.CPos x y) gls = do -- hscurses doesn't expose mvwin, so manually recreate the window in the @@ -137,16 +126,13 @@ -- default border characters are ugly on e.g. windows PuTTY, -- and trying to set C.Border to use box-drawing chars doesn't work. drawBorder :: Bool -> (Int,Int) -> C.Window -> IO () - drawBorder ascii (h,w) cw = do - let add yy xx = C.mvWAddStr cw yy xx . (subCharAscii ascii <$>) - add 0 0 $ '┌':replicate (w-2) '─' <> "┐" - sequence_ [ add y' 0 "│" >> add y' (w-1) "│" - | y' <- [1..h-2] ] + drawBorder ascii (h,w) cw = -- |This throws an error due to moving cursor out of the window - add (h-1) 0 ('└':replicate (w-2) '─' <> "┘") - `catchIO` (\_ -> pure ()) + drawBorderWith add w h `catchIO` (\_ -> pure ()) + where add yy xx = C.mvWAddStr cw yy xx . (subCharAscii ascii <$>) drawStr :: Window -> CStyle -> CP.CPos -> String -> UIM () +drawStr _ (CStyle 7 False) _ _ = pure () -- no point drawing black on black drawStr w style (CP.CPos x y) s = do ascii <- gets asciiOnly cw <- getWin w @@ -155,6 +141,33 @@ drawGlyph :: Window -> CP.CPos -> Glyph -> UIM () drawGlyph w p (Glyph ch style) = drawStr w style p $ ch:"" +drawCompositeGlyph :: Window -> CP.CPos -> CompositeGlyph -> UIM () +drawCompositeGlyph w p = drawGlyph w p . combine + where + combine gs = Glyph (combineC $ S.map glyphChar gs) (combineS $ S.map glyphStyle gs) + where + combineC cs + | cs == S.fromList ['╴','╶'] = '─' + | cs == S.fromList ['╵','╷'] = '│' + | cs == S.fromList ['╵','╶'] = '└' + | cs == S.fromList ['╵','╴'] = '┘' + | cs == S.fromList ['╷','╶'] = '┌' + | cs == S.fromList ['╷','╴'] = '┐' + | cs == S.fromList ['╴','╵','╶','╷'] = '┼' + | cs == S.fromList ['╵','╶','╷'] = '├' + | cs == S.fromList ['╴','╶','╷'] = '┬' + | cs == S.fromList ['╴','╵','╷'] = '┤' + | cs == S.fromList ['╴','╵','╶'] = '┴' + -- |These half-lines are nice in theory, and in bearlib, but badly + -- supported in common terminal emulators, so use cdot instead. + | S.size cs == 1 && S.findMin cs `elem` ['╴','╵','╶','╷'] = '·' + | otherwise = S.findMin cs + combineS = minimumBy (compare `on` (prefYellow . cstyleCol)) . S.toList + where + -- yellow < white < green < magenta + prefYellow 3 = -1 + prefYellow n = n + wErase, wRefresh, wnoutRefresh :: Window -> UIM () wErase w = liftIO . C.werase =<< getWin w wRefresh w = liftIO . C.wRefresh =<< getWin w @@ -163,8 +176,9 @@ instance TM.TermM UIM where drawStr = drawStr drawGlyph = drawGlyph + drawCompositeGlyph = drawCompositeGlyph wErase = wErase wRefresh = wRefresh drawHighlightBoxChars = drawHighlightBoxChars asciiOnly = gets asciiOnly - + isBear = pure False diff --git a/CursesUIMInstance.hs b/CursesUIMInstance.hs --- a/CursesUIMInstance.hs +++ b/CursesUIMInstance.hs @@ -35,7 +35,7 @@ | let cols = [ CH.white, CH.red, CH.green, CH.yellow , CH.blue, CH.magenta, CH.cyan, CH.black] - , c <- [CH.black,CH.blue,CH.red,CH.yellow] + , c <- [CH.black,CH.blue,CH.red,CH.magenta] ] modify $ \s -> s {dispCPairs = cpairs} setBkgrnd diff --git a/Equipment.hs b/Equipment.hs --- a/Equipment.hs +++ b/Equipment.hs @@ -3,14 +3,10 @@ data Equipment = Bag | Charm - | GrabHand + | Hook | Key | Siphon deriving (Eq, Ord, Show, Enum, Bounded) allEquipment :: [Equipment] allEquipment = [minBound..maxBound] - -equipmentStr :: Equipment -> String -equipmentStr GrabHand = "Grab hand" -equipmentStr e = show e diff --git a/Exit.hs b/Exit.hs --- a/Exit.hs +++ b/Exit.hs @@ -1,8 +1,8 @@ module Exit where data Exit - = Exit - | KeyExit + = Exit Bool + | KeyExit Bool | Entrance | UnseenBoundary | SeenBoundary diff --git a/Fov.hs b/Fov.hs new file mode 100644 --- /dev/null +++ b/Fov.hs @@ -0,0 +1,39 @@ +module Fov where + +import qualified Data.Set as S + +import Group +import qualified Pos as P + +data Fov = Fov { pFov :: S.Set P.Pos, wpFov :: S.Set P.WPos } + deriving Eq + +empty :: Fov +empty = Fov S.empty S.empty + +null :: Fov -> Bool +null (Fov ps wps) = S.null ps && S.null wps + +unions :: [Fov] -> Fov +unions fovs = Fov (S.unions $ pFov <$> fovs) (S.unions $ wpFov <$> fovs) + +union :: Fov -> Fov -> Fov +union a b = unions [a,b] + +intersection :: Fov -> Fov -> Fov +intersection (Fov ps wps) (Fov ps' wps') = Fov (ps `S.intersection` ps') (wps `S.intersection` wps') + +filter :: (P.Pos -> Bool) -> (P.WPos -> Bool) -> Fov -> Fov +filter pf wpf (Fov ps wps) = Fov (S.filter pf ps) (S.filter wpf wps) + +map :: (P.Pos -> P.Pos) -> (P.WPos -> P.WPos) -> Fov -> Fov +map pf wpf (Fov ps wps) = Fov (pf `S.map` ps) (wpf `S.map` wps) + +(\\) :: Fov -> Fov -> Fov +(Fov ps wps) \\ (Fov ps' wps') = Fov (ps S.\\ ps') (wps S.\\ wps') + +rebase :: P.Pos -> Fov -> Fov +rebase v (Fov ps wps) = Fov ((v +^) `S.map` ps) ((v +^) `S.map` wps) + +insertP :: P.Pos -> Fov -> Fov +insertP p (Fov ps wps) = Fov (S.insert p ps) wps diff --git a/Game.hs b/Game.hs --- a/Game.hs +++ b/Game.hs @@ -3,6 +3,9 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} +#ifdef DEBUG +{-# LANGUAGE TupleSections #-} +#endif module Game where @@ -49,7 +52,6 @@ , equipment :: S.Set Equipment , selectedSlot :: Maybe I.Slot , score :: Int - , life :: Int , maxLife :: Int , junk :: Int , level :: Int @@ -59,52 +61,55 @@ , prev :: Maybe Game , unseenBeats :: S.Set T.Type , prevHS :: Maybe HS.Highscore + , showRecentHS :: Bool , gen :: StdGen } maxLevel, maxScore, initLife, charmBonus :: Int maxLevel = 3 maxScore = 25 -initLife = 5 -charmBonus = 1 +initLife = 7 +charmBonus = 2 initCreatureSides, initWallSides :: Int -initCreatureSides = 36 -initWallSides = 30 +initCreatureSides = 45 +initWallSides = 45 +baseCRF :: RF.RollFrom Creature +baseCRF = RF.RollFrom initCreatureSides $ + ($ False) <$> [SmartMonster, GhostMonster, CalmMonster, FastMonster] + baseLevels :: IM.IntMap BC.BoardConf baseLevels = IM.fromList [ (1, BC.BoardConf 1 - (RF.RollFrom initCreatureSides $ replicate 5 BasicMonster) - (RF.RollFrom initWallSides $ replicate 6 Hedge)) + baseCRF + (RF.RollFrom initWallSides $ replicate 9 Hedge)) , (2, BC.BoardConf 2 - (RF.RollFrom initCreatureSides $ replicate 5 BasicMonster) - (RF.RollFrom initWallSides $ replicate 6 BasicWall <> [Pillar])) + baseCRF + (RF.RollFrom initWallSides $ replicate 9 BasicWall <> [Pillar])) , (3, BC.BoardConf 3 - (RF.RollFrom initCreatureSides $ replicate 5 BasicMonster) - (RF.RollFrom initWallSides $ replicate 6 BasicWall <> [Window, Window])) + baseCRF + (RF.RollFrom initWallSides $ replicate 9 BasicWall <> [Window, Window])) ] new :: MonadIO m => m Game new = do g <- initStdGen - pure $ Game { board = B.empty, transitions = [], inventory = I.empty, equipment = S.empty, selectedSlot = Nothing, score = 0, life = 0, maxLife = 0, junk = 0, level = 0, round = 0, roundItems = [], levels = baseLevels, prev = Nothing, unseenBeats = S.fromList T.allTypes, prevHS = Nothing, gen = g } + pure $ Game { board = B.empty, transitions = [], inventory = I.empty, equipment = S.empty, selectedSlot = Nothing, score = 0, maxLife = 0, junk = 0, level = 0, round = 0, roundItems = [], levels = baseLevels, prev = Nothing, unseenBeats = S.fromList T.allTypes, prevHS = Nothing, showRecentHS = False, gen = g } modBoard :: (B.Board -> B.Board) -> Game -> Game modBoard f game = game { board = f $ board game } setBoard :: B.Board -> Game -> Game setBoard = modBoard . const -modScore, modLife, modMaxLife, modJunk, modLevel, modRound :: (Int -> Int) -> Game -> Game +modScore, modMaxLife, modJunk, modLevel, modRound :: (Int -> Int) -> Game -> Game modScore f game = game { score = f $ score game } -modLife f game = game { life = f $ life game } modMaxLife f game = game { maxLife = f $ maxLife game } modJunk f game = game { junk = f $ junk game } modLevel f game = game { level = f $ level game } modRound f game = game { round = f $ round game } -setScore, setLife, setMaxLife, setJunk, setLevel, setRound :: Int -> Game -> Game +setScore, setMaxLife, setJunk, setLevel, setRound :: Int -> Game -> Game setScore = modScore . const -setLife = modLife . const setMaxLife = modMaxLife . const setJunk = modJunk . const setLevel = modLevel . const @@ -122,7 +127,7 @@ setPrev = modPrev . const modLifeWithMax, modScoreWithMax :: (Int -> Int) -> Game -> Game -modLifeWithMax f game = modLife (min (maxLife game) . f) game +modLifeWithMax f game = modBoard (B.modLife $ min (maxLife game) . f) game modScoreWithMax f = modScore $ min maxScore . f modTransitions :: ([B.Transition] -> [B.Transition]) -> Game -> Game @@ -153,6 +158,9 @@ setPrevHS :: Maybe HS.Highscore -> Game -> Game setPrevHS mhs game = game { prevHS = mhs } +modShowRecentHS :: (Bool -> Bool) -> Game -> Game +modShowRecentHS f game = game { showRecentHS = f $ showRecentHS game } + hasEquip :: Equipment -> Game -> Bool hasEquip e = (e `S.member`) . equipment @@ -162,7 +170,7 @@ | otherwise = 0 canGrab :: Game -> Bool -canGrab = hasEquip GrabHand +canGrab = hasEquip Hook highscore :: Maybe HS.Username -> Game -> HS.Highscore highscore name game = HS.Highscore @@ -171,6 +179,7 @@ , HS.maxLevel = fix0 $ level game , HS.equipment = equipment game , HS.name = name + , HS.gems = B.countPowers $ board game } where fix0 0 = 3 @@ -211,19 +220,28 @@ modify . modInventory . I.clearAllBut =<< gets preserveSlots modify $ modRound (+1) . setLevel 1 . setPrev Nothing charmed <- gets $ hasEquip Charm - let l = initLife + if charmed then charmBonus else 0 - modify $ setLife l . setMaxLife l - modify . setRoundItems =<< evalR (take 3 <$> shuffle findableTreasures) - enterNewBoard True =<< evalR (randMemberUnsafe B.boundaryWPoss) + modify . setMaxLife $ initLife + if charmed then charmBonus else 0 + modify . setRoundItems =<< evalR (take 4 <$> shuffle findableTreasures) + lf <- gets maxLife + enterNewBoard lf True =<< evalR (randMemberUnsafe B.boundaryWPoss) endTurn -enterNewBoard :: MonadState Game m => Bool -> P.WPos -> m () -enterNewBoard doRecharge e = do - powers <- gets $ (if doRecharge then M.map Pow.recharge else id) . B.powers . board - bc <- gets currentLevelBC +enterNewBoard :: MonadState Game m => Int -> Bool -> P.WPos -> m () +enterNewBoard lf newRound e = do + powers <- gets $ (if newRound then M.map Pow.recharge else id) . B.powers . board + sidesC <- gets $ if newRound then const initCreatureSides else RF.sides . BC.creatureRoll . B.conf . board + sidesW <- gets $ if newRound then const initWallSides else RF.sides . BC.wallRoll . B.conf . board + bc <- gets $ BC.modRolls (RF.setSides sidesC) (RF.setSides sidesW) . currentLevelBC diffs <- evalR $ BC.genDiffs bc is <- gets roundItems - modify . setBoard $ (B.enterAt e $ B.new bc) { B.powers = powers, B.diffs = diffs, B.possItems = is} + statuses <- if newRound then pure M.empty else gets $ B.statuses . board + modify . setBoard $ (B.enterAt lf e $ B.new bc) + { B.powers = powers + , B.diffs = diffs + , B.possItems = is + , B.statuses = statuses + } + modifyR $ modBoardM B.reExpect setFov where currentLevelBC game = fromMaybe BC.emptyBoardConf . (IM.!? level game) $ levels game @@ -244,19 +262,19 @@ modify . modEquipment $ S.insert e onAdd e where - enough g = junk g > S.size (equipment g) + 1 + enough g = junk g > S.size (equipment g) onAdd Charm = modify $ modMaxLife (+charmBonus) onAdd Siphon = modify . modBoard $ B.modPowers (M.map $ Pow.setOverUsable True) onAdd _ = pure () collect :: MonadState Game m => [Item] -> m () collect = mapM_ collect' where - collect' Gem = modify . modBoard . B.addPower =<< gets (hasEquip Siphon) + collect' (Gem _) = modify . modBoard . B.addPower =<< gets (hasEquip Siphon) collect' ScoreTreasure = modify $ modScoreWithMax (+1) - collect' Potion = modify $ modLifeWithMax (+4) - collect' MiniPotion = modify $ modLifeWithMax (+2) + collect' Potion = modify $ modLifeWithMax (+3) collect' Junk = addJunk - collect' (UmbrellaHandle _) = collect' (ItemInvItem Umbrella) + collect' (UmbrellaHandle _ 0) = pure () + collect' (UmbrellaHandle _ charges) = collect' (ItemInvItem $ Umbrella charges) collect' CameraBoxed = modify . modInventory $ snd . I.add (Camera initCameraCharge) collect' (RollingOrb _ _) = collect' (ItemInvItem Orb) collect' (ItemInvItem (Camera 0)) = pure () @@ -272,20 +290,20 @@ modBoardTell :: MonadState Game m => (B.Board -> Writer a B.Board) -> m a modBoardTell = modBoardTellM . (mapWriterT (pure . runIdentity) .) -exitLevel :: MonadState Game m => P.WPos -> m () -exitLevel exitPos = do - endLevel $ P.exitDir exitPos +exitLevel :: MonadState Game m => (Creature, P.WPos) -> m () +exitLevel (Player lf, exitPos) = do + modify (modLevel $ (`mod` 4) . (+1)) lev <- gets level when (lev <= maxLevel) $ - enterNewBoard False $ B.oppositeWPos exitPos - where - endLevel :: MonadState Game m => P.Dir -> m () - endLevel dir = do - diffs <- gets $ B.diffs . board - lev <- gets level - modify . modLevels $ IM.adjust (BC.apply diffs dir) lev - modify (modLevel $ (`mod` 4) . (+1)) + enterNewBoard lf False $ B.oppositeWPos exitPos +exitLevel _ = pure () +doAlarm :: MonadState Game m => P.Dir -> m () +doAlarm dir = do + diffs <- gets $ B.diffs . board + lev <- gets level + modify . modLevels $ IM.adjust (BC.apply diffs dir) lev + movePlayer :: MonadState Game m => P.Dir -> m () movePlayer dir = do bd <- gets board @@ -294,6 +312,7 @@ modify $ modLifeWithMax (+ (-(getSum $ B.damage mr))) showAlerts bd $ B.alerts mr envAct + mapM_ doAlarm $ B.alarmings mr mapM_ exitLevel $ B.exitings mr endTurn @@ -301,13 +320,20 @@ showAlerts bd alerts = unless (null alerts) $ modify . pushTransition $ B.Transition bd alerts useInvSlotInDir :: MonadState Game m => I.Slot -> P.Dir -> m () -useInvSlotInDir slot dir = +useInvSlotInDir slot dir = do + bd <- gets board gets ((M.!? slot) . I.invItems . inventory) >>= \case Nothing -> (gets canGrab >>=) . flip when $ do is <- modBoardTell (B.grabItem dir) unless (null is) $ collect is >> envAct >> endTurn + Just e@(Camera _) + | p:_ <- B.playerPoss bd + , B.creatureCanMove bd (Player 1) p dir -> do + modify . modBoard . B.modItems . M.insert p $ ItemInvItem e + modify . modInventory . I.modInvItems $ useUp slot + movePlayer dir + | otherwise -> pure () Just e -> do - bd <- gets board case runWriterT $ B.tryUseInvItem e dir bd of Nothing -> pure () Just (bd', alerts) -> do @@ -341,9 +367,8 @@ endTurn :: MonadState Game m => m () endTurn = do undoCharges <- gets $ maybe 0 Pow.activatableTimes . (M.!? undoPos) . B.powers . board - modify . eraseBefore $ undoTurns * undoCharges modify . setPrev . Just =<< get - gets ((<=0) . life) >>= flip when (modify $ modBoard B.setPlayerDead) + modify . eraseBefore $ (undoTurns+1) * undoCharges where eraseBefore n | n <= 0 = setPrev Nothing eraseBefore n = modPrev (eraseBefore (n-1) <$>) @@ -357,25 +382,25 @@ activatePower = do bd <- gets board case True of - _ | p:_ <- B.playerPoss bd + _ | (p,plc):_ <- B.players bd , Just pow <- B.powers bd M.!? p , Pow.activatable pow -> do when (Pow.tp pow == Pow.Foresight) . modifyR $ modBoardM B.beginExpect -- |XXX: Be careful of the subtle interaction with the undo power -- when changing this. - modify $ modBoard (B.modPowers $ M.alter (Pow.deplete =<<) p) . doPower (Pow.tp pow) p + modify $ modBoard (B.modPowers $ M.alter (Pow.deplete =<<) p) . doPower (Pow.tp pow) (p,plc) unless (Pow.tp pow == Pow.Undo) envAct endTurn _ -> pure () where - doPower Pow.Heal _ = modLifeWithMax (+2) + doPower Pow.Heal _ = modLifeWithMax (+1) doPower Pow.Smoke _ = modBoard $ B.incStatus B.Smoke (B.maxSmoke + 1) doPower Pow.Haste _ = modBoard $ B.incStatus B.Haste 8 - doPower Pow.Dazzle _ = modBoard $ B.incStatus B.Dazzled 5 + doPower Pow.Dazzle _ = modBoard $ B.incStatus B.Dazzled 6 doPower Pow.Ghost _ = modBoard $ B.incStatus B.Ghost 6 - doPower Pow.Foresight _ = modBoard $ B.incStatus B.Foresight 11 - doPower Pow.Teleport p = modBoard $ B.setSafe True . B.modCreatures (M.delete p . M.insert (centre +^ centre +^ neg p) Player) + doPower Pow.Foresight _ = modBoard $ B.incStatus B.Foresight 10 + doPower Pow.Teleport (p,plc) = modBoard $ B.setSafe True . B.modCreatures (M.delete p . M.insert (centre +^ centre +^ neg p) plc) doPower Pow.Undo _ = \game -> let (game',trans) = runWriter $ prevTurn undoTurns game in game' { transitions = reverse trans } where prevTurn :: Int -> Game -> Writer [B.Transition] Game prevTurn n g | n < 0 = pure g @@ -386,72 +411,81 @@ playState :: Game -> PlayState playState game | level game == 0 = RoundEnded - | life game <= 0 = Dead + | B.life bd <= 0 && not (B.canUndo bd) = Dead | score game >= maxScore = Won | Just b <- S.lookupMin $ triggeredBeats game = Tutorialising b | otherwise = Playing + where bd = board game doCommand :: (MonadState Game m, MonadIO m) => C.Command -> m () -doCommand c = gets playState >>= \case - Dead -> case c of - C.Accept -> initGame - _ -> pure () - Won -> case c of - C.Accept -> initGame - _ -> pure () - RoundEnded -> case c of - C.Accept -> nextRound - C.SkipTutorial -> modify (setUnseenBeats $ S.fromList T.allTypes) >> nextRound - _ -> pure () - Tutorialising b -> case c of - C.Accept -> modify . modUnseenBeats . S.delete $ T.tp b - C.SkipTutorial -> modify $ setUnseenBeats S.empty - _ -> pure () - Playing -> case c of - C.Dir dir -> do - gets selectedSlot >>= \case - Nothing -> movePlayer dir - Just slot -> do - modify $ setSelectedSlot Nothing - useInvSlotInDir slot dir - C.UseInv slot -> do - gets selectedSlot >>= modify . \case - Just s | s == slot -> setSelectedSlot Nothing - Just s' -> modInventory (I.swap slot s') . setSelectedSlot Nothing - Nothing -> setSelectedSlot $ Just slot - C.UsePower -> activatePower +doCommand c = do + onlyUndo <- gets $ (\bd -> B.life bd <= 0 && B.canUndo bd) . board + gets playState >>= \case + Dead -> case c of + C.Accept -> initGame + _ -> pure () + Won -> case c of + C.Accept -> initGame + _ -> pure () + RoundEnded -> case c of + C.Accept -> nextRound + C.SkipTutorial -> modify (setUnseenBeats $ S.fromList T.allTypes) >> nextRound + C.ToggleShowRecentHS -> modify $ modShowRecentHS not + _ -> pure () + Tutorialising b -> case c of + C.Accept -> modify . modUnseenBeats . S.delete $ T.tp b + C.SkipTutorial -> modify $ setUnseenBeats S.empty + _ -> pure () + Playing -> case c of + C.Dir dir | not onlyUndo -> do + gets selectedSlot >>= \case + Nothing -> movePlayer dir + Just slot -> do + modify $ setSelectedSlot Nothing + useInvSlotInDir slot dir + C.UseInv slot | not onlyUndo -> do + gets selectedSlot >>= modify . \case + Just s | s == slot -> setSelectedSlot Nothing + Just s' -> modInventory (I.swap slot s') . setSelectedSlot Nothing + Nothing -> setSelectedSlot $ Just slot + C.UsePower -> activatePower #ifdef DEBUG - C.DebugAddPower -> modify . modBoard . B.addPower =<< gets (hasEquip Siphon) - C.DebugAddJunk -> addJunk - C.DebugAddItems -> collect findableTreasures - C.DebugExit -> exitLevel =<< evalR (randElemUnsafe $ S.toList B.boundaryWPoss) + C.DebugAddPower -> modify . modBoard . B.addPower =<< gets (hasEquip Siphon) + C.DebugAddJunk -> addJunk + C.DebugAddItems -> collect findableTreasures + C.DebugExit -> exitLevel =<< (Player initLife,) <$> evalR (randElemUnsafe $ S.toList B.boundaryWPoss) + C.DebugAlarm -> doAlarm =<< evalR (randElemUnsafe P.dirs) + C.DebugWait -> const () <$> modBoardTell B.doPhysics #endif - _ -> pure () + _ -> pure () triggeredBeats :: Game -> S.Set T.Beat triggeredBeats game = S.unions . S.map triggered $ unseenBeats game where triggered T.TMeta = S.singleton T.Meta triggered T.TMeta2 = S.singleton T.Meta2 - triggered T.TMovement | p:_ <- B.playerPoss bd = S.singleton $ T.Movement p + triggered T.TMovement | p:_ <- B.playerPoss bd = S.singleton $ T.Movement p (B.life bd) triggered T.TTrapped | p:_ <- B.playerPoss bd , all (trappedDir p) P.dirs , any ((`M.member` B.walls bd) . P.wposInDir p) P.dirs - = S.singleton $ T.Trapped p + , not $ any ((\case {Just (Exit _) -> True; _ -> False}) . (B.exits bd M.!?) . P.wposInDir p) P.dirs + = S.singleton $ T.Trapped p (B.life bd) triggered T.TSeeMonster = uncurry T.SeeMonster `S.map` (S.fromList . M.assocs . M.filter isMonster $ B.creatures bd) - triggered T.TSeeExit = T.SeeExit `S.map` M.keysSet (M.filter (== Exit) $ B.exits bd) - triggered T.TSeeItem = uncurry T.SeeItem `S.map` (S.fromList . M.assocs . M.filter (`notElem` [Potion, MiniPotion, ScoreTreasure, Junk, Gem]) $ B.items bd) + triggered T.TSeeExit = T.SeeExit `S.map` M.keysSet (M.filter (== Exit True) $ B.exits bd) + triggered T.TSeeItem = uncurry T.SeeItem `S.map` (S.fromList . M.assocs . M.filter + (\case {Potion -> False; ScoreTreasure -> False; Junk -> False; Gem _ -> False; _ -> True}) $ B.items bd) triggered T.TSeePotion = T.SeePotion `S.map` M.keysSet (M.filter (== Potion) $ B.items bd) - triggered T.TSeeMiniPotion = T.SeeMiniPotion `S.map` M.keysSet (M.filter (== MiniPotion) $ B.items bd) triggered T.TSeeScore = T.SeeScore `S.map` M.keysSet (M.filter (== ScoreTreasure) $ B.items bd) triggered T.TSeeJunk = T.SeeJunk `S.map` M.keysSet (M.filter (== Junk) $ B.items bd) - triggered T.TSeeGem = T.SeeGem `S.map` M.keysSet (M.filter (== Gem) $ B.items bd) - triggered T.THurt | life game < maxLife game = sng $ T.Hurt (life game) (maxLife game) + triggered T.TSeeGem = T.SeeGem `S.map` M.keysSet (M.filter (\case {Gem _ -> True; _ -> False}) $ B.items bd) + triggered T.THurt | B.life bd < maxLife game = sng $ T.Hurt (B.life bd) (maxLife game) triggered T.TCollectItem | 1 `M.member` I.invItems (inventory game) = sng T.CollectItem triggered T.TCollectItem2 | 1 `M.member` I.invItems (inventory game) = sng T.CollectItem2 - triggered T.TCollectGem | p:_ <- B.playerPoss bd, p `M.member` B.powers bd = sng T.CollectGem + triggered T.TCollectGem | p:_ <- B.playerPoss bd, Just pow <- B.powers bd M.!? p = sng . T.CollectGem $ Pow.tp pow triggered T.TCollectScore | score game == 1 = sng T.CollectScore - triggered T.TTimer | (RF.sides . BC.creatureRoll $ B.conf bd) < initCreatureSides - 2 = sng T.Timer - triggered T.TSecondRound | round game > 1 = sng T.SecondRound + triggered T.TTimer | (RF.sides . BC.wallRoll $ B.conf bd) < initWallSides - 4 = sng T.Timer + triggered T.TMustBreak | p:_ <- B.playerPoss bd + , wp:_ <- filter ((== Just (Exit True)) . (B.exits bd M.!?)) $ P.wposInDir p <$> P.dirs + = sng $ T.MustBreak wp triggered T.TTutEnd | S.size (unseenBeats game) == 1 = sng T.TutEnd triggered _ = S.empty trappedDir p dir = or [ not $ B.inBounds p' diff --git a/Geometry.hs b/Geometry.hs --- a/Geometry.hs +++ b/Geometry.hs @@ -23,8 +23,8 @@ geometry = M.fromList [ (StatusWin, WinDim 0 0 scrW 2) , (BoardWin, WinDim 1 3 (bdcW+1) bdcH) - , (InvWin, WinDim (1+bdcW+3) 3 20 (3 + length I.slots)) - , (EquipWin, WinDim (1+bdcW+3+20) 3 15 (3 + length I.slots)) + , (InvWin, WinDim (1+bdcW+3) 3 20 (4 + length I.slots)) + , (EquipWin, WinDim (1+bdcW+3+20) 3 15 (4 + length I.slots)) , (LevelInfoWin, WinDim 1 (1 + afterBoard) scrW 3) , (MessageWin, WinDim 0 (1 + 3 + 1 + afterBoard) scrW 1) , (MainWin, WinDim 0 0 scrW scrH) diff --git a/Highscore.hs b/Highscore.hs --- a/Highscore.hs +++ b/Highscore.hs @@ -1,11 +1,13 @@ module Highscore where import Data.Function (on) -import Data.List (sort) +import qualified Data.List (sort) + import qualified Data.Set as S import Equipment +import qualified HighscoreV1 as HS1 type Username = String @@ -15,18 +17,23 @@ , maxLevel :: Int , name :: Maybe Username , equipment :: S.Set Equipment + , gems :: Int } deriving Eq instance Ord Highscore where - (<=) = (<=) `on` (\hs -> (-score hs, maxRound hs, maxLevel hs)) + (<=) = (<=) `on` (\hs -> (-score hs, maxRound hs, maxLevel hs, -gems hs)) type Highscores = [Highscore] -maxHighscores :: Int -maxHighscores = 10 +sort :: [Highscore] -> [Highscore] +sort = Data.List.sort add :: Highscore -> Highscores -> Highscores -add hs = take maxHighscores . sort . (hs:) +add hs = (hs:) empty :: Highscores empty = [] + +-- backwards-compatibility shim +fromV1 :: HS1.Highscore -> Highscore +fromV1 (HS1.Highscore s mr ml n e) = Highscore s mr ml n e 0 diff --git a/HighscoreFile.hs b/HighscoreFile.hs --- a/HighscoreFile.hs +++ b/HighscoreFile.hs @@ -1,9 +1,8 @@ -module HighscoreFile where +module HighscoreFile (add, get) where import Codec.Serialise import Control.Exception.Safe import Control.Monad -import Data.Either import System.Directory import System.FileLock (SharedExclusive (..), withFileLock) import System.FilePath (()) @@ -18,14 +17,20 @@ createDirectoryIfMissing True dir pure $ dir "highscores" +readHSs :: String -> IO HS.Highscores +readHSs path = + handleAny (const tryV1) $ readFileDeserialise path + where + tryV1 = (either (const HS.empty) (HS.fromV1 <$>) <$>) . tryAny $ readFileDeserialise path + add :: HS.Highscore -> IO () add hs = do path <- getPath - withFileLock (path<>".lock") Exclusive $ \_ -> do - hss <- (fromRight HS.empty <$>) . tryAny $ readFileDeserialise path - void . tryAny . writeFileSerialise path $ HS.add hs hss + withFileLock (path<>".lock") Exclusive $ \_ -> + (void . tryAny . writeFileSerialise path) . HS.add hs =<< readHSs path get :: IO HS.Highscores get = do path <- getPath - (fromRight HS.empty <$>) . tryAny . withFileLock (path<>".lock") Shared $ \_ -> readFileDeserialise path + withFileLock (path<>".lock") Shared $ \_ -> + readHSs path diff --git a/HighscoreV1.hs b/HighscoreV1.hs new file mode 100644 --- /dev/null +++ b/HighscoreV1.hs @@ -0,0 +1,19 @@ +module HighscoreV1 where + +import qualified Data.Set as S + +import Equipment + +type Username = String + +-- Old version of high score record, preserved so we can load and convert +-- highscore files from old versions of the game +data Highscore = Highscore + { score :: Int + , maxRound :: Int + , maxLevel :: Int + , name :: Maybe Username + , equipment :: S.Set Equipment + } deriving Eq + +type Highscores = [Highscore] diff --git a/Item.hs b/Item.hs --- a/Item.hs +++ b/Item.hs @@ -1,15 +1,15 @@ module Item where -import qualified Pos as P +import qualified Pos as P +import Power (PowerType) data Item - = Gem + = Gem PowerType | ScoreTreasure | Junk - | UmbrellaHandle P.Dir + | UmbrellaHandle P.Dir Int | CameraBoxed | Potion - | MiniPotion | RollingOrb { orbRollDir :: P.Dir, orbJustDropped :: Bool } | ItemInvItem InvItem deriving (Eq, Ord) @@ -17,7 +17,7 @@ data InvItem = Cloak | Orb - | Umbrella + | Umbrella Int | Balloon Int | Flash | Camera Int @@ -25,16 +25,17 @@ | Spraypaint Int deriving (Eq, Ord, Show, Read) -initCameraCharge, initBalloonCharges, initSpraypaintCharges :: Int -initCameraCharge = 10 +initCameraCharge, initBalloonCharges, initSpraypaintCharges, initUmbrellaCharges :: Int +initCameraCharge = 20 initBalloonCharges = 3 initSpraypaintCharges = 5 +initUmbrellaCharges = 8 findableTreasures :: [Item] findableTreasures = [ ItemInvItem Cloak , ItemInvItem Orb - , ItemInvItem Umbrella + , ItemInvItem (Umbrella initUmbrellaCharges) , ItemInvItem (Balloon initBalloonCharges) , ItemInvItem Flash , ItemInvItem Tent diff --git a/KeyBindings.hs b/KeyBindings.hs --- a/KeyBindings.hs +++ b/KeyBindings.hs @@ -48,6 +48,11 @@ , ('S', C.Dir P.DDown) , ('W', C.Dir P.DUp) , ('D', C.Dir P.DRight) + -- |for dvorak + , ('E', C.Dir P.DRight) + , ('O', C.Dir P.DDown) + , (',', C.Dir P.DUp) + , ('<', C.Dir P.DUp) ] cursorBindings = @@ -65,18 +70,24 @@ , ('\r', C.Accept) , ('\n', C.Accept) , ('\f', C.Redraw) - , (ctrl 'Z', C.Suspend) + -- XXX: disabling suspend, because it seems to be broken for no apparent + -- reason. + --, (ctrl 'Z', C.Suspend) , ('t', C.SkipTutorial) , ('T', C.SkipTutorial) , ('-', C.ToggleAscii) + , ('r', C.ToggleShowRecentHS) + , ('R', C.ToggleShowRecentHS) ] debugBindings :: KeyBindings debugBindings = - [ ('P', C.DebugAddPower) - , ('J', C.DebugAddJunk) - , ('I', C.DebugAddItems) - , ('E', C.DebugExit) + [ (ctrl 'P', C.DebugAddPower) + , (ctrl 'J', C.DebugAddJunk) + , (ctrl 'I', C.DebugAddItems) + , (ctrl 'E', C.DebugExit) + , (ctrl 'A', C.DebugAlarm) + , (ctrl 'W', C.DebugWait) ] defaultBindings = quitBindings <> debugBindings <> wasdBindings <> qwertyViBindings <> cursorBindings <> actionBindings <> basicBindings diff --git a/Pos.hs b/Pos.hs --- a/Pos.hs +++ b/Pos.hs @@ -98,3 +98,9 @@ | x' <= 0 = DLeft | otherwise = DRight +-- distance in grid of doubled resolution +distSquaredToWPos :: Pos -> WPos -> Int +distSquaredToWPos p (WPos p' up') = + let dir = if up' then DUp else DRight + Pos x' y' = p +^ p +^ neg (p' +^ p' +^ dirPos dir) + in x'*x' + y'*y' diff --git a/RollFrom.hs b/RollFrom.hs --- a/RollFrom.hs +++ b/RollFrom.hs @@ -13,6 +13,8 @@ modVals f from = from { vals = f $ vals from } modSides :: (Int -> Int) -> RollFrom a -> RollFrom a modSides f from = from { sides = f $ sides from } +setSides :: Int -> RollFrom a -> RollFrom a +setSides = modSides . const roll :: (Eq a, Ord a) => RollFrom a -> Rand StdGen (Maybe a) roll from = do diff --git a/Serialise.hs b/Serialise.hs --- a/Serialise.hs +++ b/Serialise.hs @@ -19,8 +19,10 @@ import qualified Board as B import qualified BoardConf as BC +import qualified Fov as F import qualified Game as G import qualified Highscore as HS +import qualified HighscoreV1 as HS1 import qualified Inventory as I import qualified Pos as P import qualified RollFrom as RF @@ -53,6 +55,8 @@ instance Serialise BC.Diffable deriving instance Generic a => Generic (BC.RollFromDiff a) instance (Generic a, Serialise a) => Serialise (BC.RollFromDiff a) +deriving instance Generic F.Fov +instance Serialise F.Fov deriving instance Generic B.Status instance Serialise B.Status deriving instance Generic B.Board @@ -83,3 +87,5 @@ deriving instance Generic HS.Highscore instance Serialise HS.Highscore +deriving instance Generic HS1.Highscore +instance Serialise HS1.Highscore diff --git a/TermDraw.hs b/TermDraw.hs --- a/TermDraw.hs +++ b/TermDraw.hs @@ -6,12 +6,12 @@ module TermDraw where import Control.Concurrent (threadDelay) -import Control.Monad (forM, forM_, mplus, unless, void) +import Control.Monad (forM, forM_, mplus, unless, void, when) import Control.Monad.State (get, lift, liftIO, put, runStateT) import Data.Bifunctor (bimap) -import Data.Function (on) -import Data.List (intersperse, minimumBy) -import Data.Maybe (fromMaybe, isJust, isNothing, maybeToList) +import Data.List (intersperse, (\\)) +import Data.Maybe (fromMaybe, isJust, listToMaybe, + maybeToList) import Safe (atMay) #if !MIN_VERSION_base(4,20,0) @@ -35,6 +35,7 @@ import qualified Board as B import qualified BoardConf as BC import qualified CPos as CP +import qualified Fov as F import qualified Game as G import qualified Highscore as HS import qualified HighscoreFile as HSF @@ -50,7 +51,7 @@ c = case e of Orb -> 'o' Cloak -> '[' - Umbrella -> '/' + Umbrella _ -> '/' Balloon _ -> '&' Flash -> '=' Camera _ -> ')' @@ -65,51 +66,53 @@ put $ x + length s twoCharNum :: Int -> String -twoCharNum n | 0 <= n && n < 10 = ' ' : show n +twoCharNum n + | 0 <= n && n < 10 = ' ' : show n | otherwise = take 2 $ show n +-- |Apply style only to the number, not spacing +twoCharNumStyled :: Int -> CStyle -> [(String, CStyle)] +twoCharNumStyled n style + | 0 <= n && n < 10 = [(" ", style0), (show n, style)] + | otherwise = [(take 2 $ show n, style)] + drawStatus :: TM.TermM m => G.Game -> m () -drawStatus (G.Game { G.life = life, G.maxLife = maxLife, G.score = score, G.level = level, G.round = rnd, G.junk = junk, G.equipment = equipment, G.board = B.Board { B.statuses = statuses } }) = do +drawStatus (G.Game { G.maxLife = maxLife, G.score = score, G.level = level, G.round = rnd, G.junk = junk, G.equipment = equipment, G.board = bd }) = do let win = StatusWin unless (M.null statuses) $ drawStyledStrs win (CP.CPos 0 0) statusStrs drawStyledStrs win (CP.CPos 0 1) numStrs where + statuses = B.statuses bd + life = B.life bd -- XXX: keep in sync with magic numbers in highlightTut numStrs = [ ("Life: ", style0) - , (twoCharNum life, lifeStyle) - , ("/", style0) + ] <> twoCharNumStyled life (lifeStyle life) <> + [ ("/", style0) , (show maxLife, if maxLife == G.initLife then style0 else equipStyle Charm) , (" Score: ", style0) , (twoCharNum score <> "/" <> show G.maxScore, style0) , ("~", scoreStyle) , (" Level: " <> twoCharNum rnd <> ":", style0) , (showLevel level, levelStyle level) - ] <> if junk == 0 && S.null equipment then [] else + ] <> [ (" Junk: ", style0) - , (twoCharNum junk <> "/" <> show (S.size equipment + 2), style0) + , (twoCharNum junk <> "/" <> show (S.size equipment + 1), style0) , ("%", junkStyle) ] - lifeStyle = case life of - n | n <= 0 -> CStyle (onRed black) True - 1 -> CStyle red True - 2 -> CStyle red False - 3 -> CStyle yellow True - 4 -> CStyle yellow False - 5 -> style0 - 6 -> CStyle green False - _ -> CStyle green True statusStrs = intersperse (" ", style0) - [ (show (fst status) <> " " <> twoCharNum (snd status), statStyle status) - | status <- M.assocs statuses ] + [ (show stat <> " " <> twoCharNum n, statStyle status) + | status@(stat,n) <- M.assocs statuses + , n > 0 ] statStyle (B.Dazzled,_) = CStyle cyan True - statStyle (B.Ghost,_) = style0 + statStyle (B.Ghost,_) = styleBold statStyle (B.Smoke,_) = CStyle blue True statStyle (B.Haste,n) = CStyle (if n `mod` 2 == 1 then red else yellow) True - statStyle (B.Foresight,_) = styleBold + statStyle (B.Foresight,_) = CStyle yellow False -exitChar :: P.Dir -> Char -exitChar = \case +exitChar :: Bool -> P.Dir -> Char +exitChar True = const 'x' +exitChar False = \case P.DUp -> '^' P.DDown -> 'v' P.DRight -> '>' @@ -142,6 +145,9 @@ alerted { creatureMoves = M.insert (P.wposInDir p d) c $ creatureMoves alerted , base = B.modCreatures (M.delete p) $ base alerted } + applyAlert alerted (B.AlertMoveCreatureVia c p) = + alerted { base = B.modCreatures (M.insert p c) $ base alerted + } applyAlert alerted (B.AlertMoveItem i p d) = alerted { itemMoves = M.insert (P.wposInDir p d) i $ itemMoves alerted , base = B.modItems (M.delete p) $ base alerted @@ -155,10 +161,11 @@ , highlightWPs = wps `S.union` highlightWPs alerted } -char,bold,dim :: Char -> Glyph +char,bold,dim,boldDim :: Char -> Glyph char c = Glyph c style0 bold c = Glyph c styleBold dim c = Glyph c $ CStyle (onBlue white) False +boldDim c = Glyph c $ CStyle (onBlue white) True levelStyle :: Int -> CStyle levelStyle 1 = CStyle green False @@ -171,30 +178,58 @@ showLevel _ = "-" scoreStyle, junkStyle :: CStyle -scoreStyle = CStyle yellow False +scoreStyle = CStyle yellow True junkStyle = CStyle blue True +lifeStyle :: Int -> CStyle +lifeStyle = \case + n | n <= 0 -> CStyle (onRed black) True + 1 -> CStyle red True + 2 -> CStyle red False + 3 -> CStyle yellow True + 4 -> CStyle yellow False + n | n <= G.initLife -> style0 + _ -> CStyle green False + creatureGlyph :: Creature -> Glyph -creatureGlyph Player = bold '@' -creatureGlyph DeadPlayer = Glyph '@' $ CStyle (onRed black) True -creatureGlyph BasicMonster = Glyph 'm' $ CStyle yellow False -creatureGlyph CalmMonster = Glyph 'p' $ CStyle blue True -creatureGlyph ChaseMonster = Glyph 'c' $ CStyle yellow True -creatureGlyph GhostMonster = Glyph 'g' $ CStyle white True -creatureGlyph SmartMonster = Glyph 's' $ CStyle red True +creatureGlyph (Player life) = Glyph '@' $ lifeStyle life +creatureGlyph BasicMonster = Glyph 'm' $ CStyle yellow False +creatureGlyph (CalmMonster False) = Glyph 'p' $ CStyle blue True +creatureGlyph (CalmMonster True) = Glyph 'P' $ CStyle blue True +creatureGlyph (GhostMonster False) = Glyph 'g' $ CStyle white True +creatureGlyph (GhostMonster True) = Glyph 'G' $ CStyle white True +creatureGlyph (SmartMonster False) = Glyph 's' $ CStyle red True +creatureGlyph (SmartMonster True) = Glyph 'S' $ CStyle cyan True +creatureGlyph (FastMonster False) = Glyph 'f' $ CStyle magenta True +creatureGlyph (FastMonster True) = Glyph 'F' $ CStyle magenta True creatureGlyph (InflatedBalloon charges) = Glyph '0' . CStyle magenta $ charges > 0 itemGlyph :: Item -> Glyph -itemGlyph Gem = Glyph '*' $ CStyle green True -itemGlyph Potion = Glyph '!' $ CStyle green True -itemGlyph MiniPotion = Glyph '!' $ CStyle green False -itemGlyph ScoreTreasure = Glyph '~' scoreStyle -itemGlyph Junk = Glyph '%' junkStyle -itemGlyph (UmbrellaHandle d) = Glyph (if d `elem` [P.DUp, P.DDown] then '|' else '-') $ CStyle magenta True +itemGlyph (Gem pow) = Glyph '*' $ powerStyle pow +itemGlyph Potion = Glyph '!' $ CStyle green True +itemGlyph ScoreTreasure = Glyph '~' scoreStyle +itemGlyph Junk = Glyph '%' junkStyle +itemGlyph (UmbrellaHandle d ch) = Glyph (if d `elem` [P.DUp, P.DDown] then '|' else '-') $ CStyle magenta (ch > 0) itemGlyph CameraBoxed = Glyph ')' $ CStyle cyan False -itemGlyph (RollingOrb _ _) = Glyph 'o' $ CStyle cyan False -itemGlyph (ItemInvItem e) = invItemGlyph e +itemGlyph (RollingOrb _ _) = Glyph 'o' $ CStyle cyan False +itemGlyph (ItemInvItem e) = invItemGlyph e +powerGlyph :: Pow.Power -> Glyph +powerGlyph pow = case Pow.charges pow of + 0 | Pow.overUsable pow -> Glyph ',' . powerStyle $ Pow.tp pow + 0 -> Glyph ',' style0 + _ -> Glyph '"' $ powerStyle $ Pow.tp pow + +powerStyle :: Pow.PowerType -> CStyle +powerStyle Pow.Heal = CStyle green True +powerStyle Pow.Dazzle = CStyle cyan True +powerStyle Pow.Smoke = CStyle blue True +powerStyle Pow.Haste = CStyle red True +powerStyle Pow.Teleport = CStyle green False +powerStyle Pow.Undo = CStyle magenta True +powerStyle Pow.Ghost = CStyle white True +powerStyle Pow.Foresight = CStyle yellow False + wallGlyphVert :: Wall -> Glyph wallGlyphVert = \case BasicWall -> bold wallchar @@ -227,18 +262,18 @@ exitGlyphVert :: CStyle -> P.WPos -> Exit -> Glyph exitGlyphVert st wp = \case - Exit -> bold $ exitChar (P.exitDir wp) - KeyExit -> Glyph (exitChar (P.exitDir wp)) $ equipStyle Key - Entrance -> char 'x' - UnseenBoundary -> char '.' + Exit locked -> bold $ exitChar locked (P.exitDir wp) + KeyExit locked -> Glyph (exitChar locked (P.exitDir wp)) $ equipStyle Key + Entrance -> exitGlyphVert st wp SeenBoundary + UnseenBoundary -> char '·' SeenBoundary -> Glyph '│' st exitGlyphHoriz :: CStyle -> P.WPos -> Exit -> (Glyph,Glyph) exitGlyphHoriz st wp = \case - Exit -> (bold $ exitChar (P.exitDir wp), Glyph '─' st) - KeyExit -> (Glyph (exitChar (P.exitDir wp)) $ equipStyle Key, Glyph '─' st) - Entrance -> (char 'x', Glyph '─' st) - UnseenBoundary -> doublet $ char '.' + Exit locked -> (bold $ exitChar locked (P.exitDir wp), Glyph '─' st) + KeyExit locked -> (Glyph (exitChar locked (P.exitDir wp)) $ equipStyle Key, Glyph '─' st) + Entrance -> exitGlyphHoriz st wp SeenBoundary + UnseenBoundary -> doublet $ char '·' SeenBoundary -> doublet $ Glyph '─' st where doublet gl = (gl,gl) @@ -255,8 +290,8 @@ drawAlertedBoard AlertedBoard{ base = bd, creatureMoves = cmvs, itemMoves = imvs, itemUses = iuses, highlightPs = hps, highlightWPs = hwps } = let wallsV :: M.Map P.WPos Glyph wallsH :: M.Map P.WPos (Maybe Glyph,Maybe Glyph) - wallsV = highlightV `M.union` mvingV `M.union` wObscuredV `M.union` bdWallsV `M.union` borderV - wallsH = highlightH `M.union` mvingH `M.union` wObscuredH `M.union` bdWallsH `M.union` borderH + wallsV = highlightV `M.union` mvingV `M.union` wObscuredV `M.union` bdWallsV `M.union` borderV `M.union` bgWallsV + wallsH = highlightH `M.union` mvingH `M.union` wObscuredH `M.union` bdWallsH `M.union` borderH `M.union` bgWallsH cells, items, creatures, obscured, powers :: M.Map P.Pos (Maybe Glyph,Maybe Glyph) layer = M.unionWith $ \(l,r) (l',r') -> (l `mplus` l', r `mplus` r') cells = highlightCells `layer` obscured `layer` creatures `layer` items `layer` powers @@ -264,37 +299,43 @@ filterH = M.filterWithKey $ const . P.up filterSV = S.filter $ not . P.up filterSH = S.filter P.up + mapH :: (Glyph -> a) -> (Glyph,Glyph) -> (a,a) + mapH f = bimap f f glyphsV f m = M.mapWithKey f $ filterV m - glyphsH f m = M.mapWithKey ((bimap Just Just .) . f) $ filterH m - borderV = glyphsV (exitGlyphVert levBoundSt) $ B.exits bd - borderH = glyphsH (exitGlyphHoriz levBoundSt) $ B.exits bd + glyphsH f m = M.mapWithKey ((mapH Just .) . f) $ filterH m + borderV = glyphsV (\wp -> markObscure wp . exitGlyphVert levBoundSt wp) $ B.exits bd + borderH = glyphsH (\wp -> mapH (markObscure wp) . exitGlyphHoriz levBoundSt wp) $ B.exits bd + wpFov = F.wpFov $ B.visible bd + pFov = F.pFov $ B.visible bd + markObscure wp + | wp `S.member` wpFov = id + | otherwise = modColour onBlue bdWallsV = glyphsV (const wallGlyphVert) $ B.walls bd bdWallsH = glyphsH (const wallGlyphHoriz) $ B.walls bd + -- |black on black background grid, ignored by CursesUI + bgWallsV = M.fromSet (const . Glyph '│' $ CStyle black False) . filterSV $ B.wPossIncBdd + bgWallsH = M.fromSet (const . biGlyph . Glyph '─' $ CStyle black False) . filterSH $ B.wPossIncBdd levBoundSt = levelStyle . BC.level $ B.conf bd items = M.mapWithKey itemGlyphs $ B.items bd itemGlyphs p i = (Nothing,) . Just . powerBG p $ itemGlyph i biGlyph gl = (Just gl, Just gl) powerBG :: P.Pos -> Glyph -> Glyph powerBG p - | Just pow <- B.powers bd M.!? p, Pow.charges pow > 0 = modColour onRed + | Just pow <- B.powers bd M.!? p, Pow.charges pow > 0 = modColour onMagenta -- | Just pow <- B.powers bd M.!? p, Pow.overUsable pow = modColour onYellow | otherwise = id powers = (Nothing,) . Just . powerGlyph <$> B.powers bd - powerGlyph pow = Glyph '"' $ case True of - _ | Pow.charges pow > 0 -> CStyle red True - _ | Pow.overUsable pow -> equipStyle Siphon - _ -> style0 creatures = (,Nothing) . Just . creatureGlyph' <$> B.creatures bd - creatureGlyph' Player = Glyph '@' $ CStyle col (not $ B.ghostly bd) where - col | B.isHasteRound bd = red - | B.hasted bd = yellow - | otherwise = white + creatureGlyph' (Player life) = Glyph '@' $ (lifeStyle life) { cstyleBold = not $ B.ghostly bd } creatureGlyph' c = creatureGlyph c - obscured = M.fromSet (\p -> (Just . dim $ expectChar p,) . Just . powerBG p . dim $ obsChar p) $ B.poss S.\\ B.visible bd where + obscured = M.fromSet (\p -> (Just . dim $ expectChar p,) . Just . powerBG p . obsStyle $ obsChar p) $ B.poss S.\\ pFov where expectChar p - | B.expectant bd + | B.preexpectant bd , Just (Just c) <- B.expected bd M.!? p = glyphChar $ creatureGlyph' c | otherwise = ' ' + obsStyle + | S.size (B.unrevealed bd) == 1 = boldDim + | otherwise = dim obsChar p | p `S.member` B.unrevealed bd = expectedTreasureChar p | otherwise = ' ' @@ -311,30 +352,49 @@ highlightH = M.fromSet (const . biGlyph $ bold '#') $ filterSH hwps -- Positions with wall-intersection to top-right - intersections :: M.Map P.Pos Glyph - intersections = iHighlighted `M.union` iObscured `M.union` iWalls - iWalls = M.map (Glyph '·') . M.unionsWith pref $ M.fromList <$> - [ [ (p,i), (p <> if up then P.Pos (-1) 0 else P.Pos 0 (-1),i) ] - | (P.WPos p up, Just i) <- M.toList $ - M.map wallI (B.walls bd) `M.union` M.map (const $ Just exitCol) (B.exits bd) ] + intersections :: M.Map P.Pos CompositeGlyph + intersections = iHighlighted `M.union` iWalls `M.union` iObscured where - wallI BasicWall = Just $ CStyle white True - wallI Hedge = Just $ CStyle green True - wallI ThickHedge = Just $ CStyle green False - wallI Pillar = Nothing - wallI Window = Nothing - wallI BrokenWindow = Nothing - wallI (UmbrellaWall _) = Nothing - wallI (CloakWall _ _) = Just $ CStyle cyan True - wallI TentWall = Just $ CStyle red True - exitCol = levBoundSt - pref a b = minimumBy (compare `on` cstyleCol) [a,b] -- white < green < magenta - iObscured = M.fromSet (const $ dim ' ') $ S.filter (\p -> P.x p < B.w-1 && P.y p < B.h-1 && - and [ p' `S.member` M.keysSet obscured || not (B.inBounds p') - | p' <- (p +^) <$> [ P.Pos x y | x <- [0,1], y <- [0,1] ] ]) B.poss - iHighlighted = M.fromSet (const $ bold '#') $ S.filter (\p -> P.x p < B.w-1 && P.y p < B.h-1 && - and [ p' `S.member` hps - | p' <- (p +^) <$> [ P.Pos x y | x <- [0,1], y <- [0,1] ] ]) B.poss + iWalls = M.mapMaybeWithKey obscureI . M.unionsWith S.union $ M.map mk . M.fromList <$> + [ [ (p, (d,s)), (p <> if up then P.Pos (-1) 0 else P.Pos 0 (-1),(P.negDir d,s)) ] + | (P.WPos p up, Just s) <- M.toList $ + M.map wallI (B.walls bd) `M.union` M.map exitCol (B.exits bd) + , let d = if up then P.DRight else P.DUp + ] + where + mk :: (P.Dir, CStyle) -> CompositeGlyph + mk (d,s) = S.singleton $ Glyph (mk' d) s + where + mk' P.DUp = '╷' + mk' P.DRight = '╴' + mk' P.DDown = '╵' + mk' P.DLeft = '╶' + wallI BasicWall = Just $ CStyle white True + wallI Hedge = Just $ CStyle green True + wallI ThickHedge = Just $ CStyle green False + wallI Pillar = Nothing + wallI Window = Nothing + wallI BrokenWindow = Nothing + wallI (UmbrellaWall _) = Nothing + wallI (CloakWall _ _) = Just $ CStyle cyan True + wallI TentWall = Just $ CStyle red True + exitCol UnseenBoundary = Nothing + exitCol _ = Just levBoundSt + obscureI :: P.Pos -> CompositeGlyph -> Maybe CompositeGlyph + obscureI p cg + | p `S.member` M.keysSet iObscured = if isBdI p + then Just $ modColour onBlue `S.map` cg + else Nothing + | otherwise = Just cg + iObscured = M.fromSet (S.singleton . dim . (\p -> if isBdI p then '·' else ' ')) + . (`S.filter` iPoss) $ \p -> + 2 > (length . filter (`S.member` wpFov) $ intAdjWps p) + iHighlighted = M.fromSet (const . S.singleton $ bold '#') . (`S.filter` iPoss) $ \p -> + (if isCornerI p then 1 else 2) < (length . filter (`S.member` hwps) $ intAdjWps p) + iPoss = S.fromList [ P.Pos x y | x <- [-1..B.w-1], y <- [-1..B.h-1] ] + isBdI (P.Pos x y) = x == -1 || x == B.w-1 || y == -1 || y == B.h-1 + isCornerI (P.Pos x y) = (x,y) `elem` [(-1,-1),(-1,B.h-1),(B.w-1,B.h-1),(B.w-1,-1)] + intAdjWps p = [P.WPos p True, P.WPos p False, P.WPos (p +^ P.dirPos P.DRight) True, P.WPos (p +^ P.dirPos P.DUp) False] horizCPosMap :: M.Map P.Pos (Maybe Glyph, Maybe Glyph) -> M.Map CP.CPos Glyph horizCPosMap m = M.mapMaybe fst (M.mapKeys posCPosL m) `M.union` M.mapMaybe snd (M.mapKeys posCPosR m) @@ -346,44 +406,51 @@ [ horizCPosMap cells , M.mapKeys wposCPos wallsV , horizWCPosMap wallsH - , M.mapKeys posIntCPos intersections ] + compGlyphs :: M.Map CP.CPos CompositeGlyph + compGlyphs = M.mapKeys posIntCPos intersections in do sequence_ $ M.mapWithKey (TM.drawGlyph BoardWin) glyphs + sequence_ $ M.mapWithKey (TM.drawCompositeGlyph BoardWin) compGlyphs drawInv :: TM.TermM m => Maybe I.Slot -> Int -> Bool -> I.Inventory -> Maybe Pow.Power -> m () -drawInv sel preserve highlightEmpty (I.Inventory inv) pow = do +drawInv sel preserve hasHook (I.Inventory inv) pow = do let win = InvWin let str x y st = TM.drawStr win st (CP.CPos x y) + let firstEmpty = listToMaybe $ I.slots \\ M.keys inv str 0 0 styleBold "Inventory:" sequence_ $ [ do str 0 slot style (show slot) case me of - Nothing -> pure () + Nothing -> when hookSlot $ str 4 slot style "[Hook]" Just e -> do TM.drawGlyph win (CP.CPos 2 slot) (invItemGlyph e) str 4 slot style $ show e | slot <- I.slots , let me = inv M.!? slot - , let style = CStyle col b where - col | slot <= preserve = yellow - | highlightEmpty && isNothing me = red + hookSlot = hasHook && Just slot == firstEmpty + style = CStyle col b where + col | hookSlot = cstyleCol $ equipStyle Hook + | slot <= preserve = yellow | otherwise = white b = sel == Just slot ] <> - [ str 0 (length I.slots + 2) style $ "0 \" " <> show tp <> " " <> show charges <> "/" <> show maxCharges - | Pow.Power tp charges maxCharges overUsable <- maybeToList pow - , let style | overUsable && charges == 0 = equipStyle Siphon - | otherwise = CStyle red $ charges > 0 + [ str 0 y style powStr >> bang + | p@(Pow.Power tp charges maxCharges overUsable) <- maybeToList pow + , let Glyph c style = powerGlyph p + , let y = length I.slots + 2 + , let powStr = "0 " <> [c] <> " " <> show tp <> " " <> show charges <> "/" <> show maxCharges + , let bang | overUsable && charges == 0 = str (length powStr) y (equipStyle Siphon) "!" + | otherwise = pure () ] equipStyle :: Equipment -> CStyle -equipStyle Bag = CStyle yellow False -equipStyle Charm = CStyle green True -equipStyle GrabHand = CStyle red False -equipStyle Key = CStyle blue True -equipStyle Siphon = CStyle yellow True +equipStyle Bag = CStyle yellow False +equipStyle Charm = CStyle green True +equipStyle Hook = CStyle red False +equipStyle Key = CStyle blue True +equipStyle Siphon = CStyle yellow True drawEquip :: TM.TermM m => S.Set Equipment -> m () drawEquip es | S.null es = pure () @@ -406,24 +473,30 @@ _ -> ("", style0) TM.drawStr win style (CP.CPos 0 0) text +delSideGlyph :: Glyph +delSideGlyph = Glyph 'x' $ CStyle red False + drawLevelInfo :: TM.TermM m => B.Board -> m () drawLevelInfo bd = do drawRoll 0 (BC.creatureRoll bc) G.initCreatureSides creatureGlyph drawRoll 1 (BC.wallRoll bc) G.initWallSides wallGlyphVert drawDiffsLine 2 + drawFound where win = LevelInfoWin nullGlyph = char '-' drawRoll :: TM.TermM m => Int -> RF.RollFrom a -> Int -> (a -> Glyph) -> m () drawRoll m roll initSides f = sequence_ $ [ TM.drawGlyph win (CP.CPos n m) $ maybe nullGlyph f (RF.vals roll `atMay` n) - | n <- [0 .. RF.sides roll - 1] - ] <> [ TM.drawGlyph win (CP.CPos initSides m) $ char ']' ] + | n <- [0 .. RF.sides roll - 1] ] + <> [ TM.drawGlyph win (CP.CPos n m) delSideGlyph | n <- [RF.sides roll .. initSides - 1] ] bc = B.conf bd diffs = B.diffs bd - drawDiffsLine y = TM.drawStr win style0 (CP.CPos 0 y) introStr >> sequence_ + drawDiffsLine y + | null possibleExitDirs = pure () + | otherwise = TM.drawStr win style0 (CP.CPos 0 y) introStr >> sequence_ [ do - draw b . char' $ exitChar dir + draw b . char' $ exitChar False dir draw (b+1) (char ':') forM (zip [0..] rdfs) (\(x,rdf) -> draw (b+3+x) $ rdfGlyph rdf) | (n,dir) <- zip [0..] P.dirs @@ -436,16 +509,22 @@ , Just rdfs <- [diffs M.!? dir] ] where - introStr = "On exit: " + introStr = "Seal: " draw x = TM.drawGlyph win (CP.CPos x y) rdfGlyph (BC.Add (BC.DiffableCreature c)) = creatureGlyph c rdfGlyph (BC.Swap _ (BC.DiffableCreature c)) = creatureGlyph c rdfGlyph (BC.Add (BC.DiffableWall wl)) = wallGlyphVert wl rdfGlyph (BC.Swap _ (BC.DiffableWall wl)) = wallGlyphVert wl exitsWith ex = P.exitDir <$> M.keys (M.filter (== ex) (B.exits bd)) - exitDirs = exitsWith Exit - keyExitDirs = exitsWith KeyExit + exitDirs = exitsWith (Exit True) + keyExitDirs = exitsWith (KeyExit True) possibleExitDirs = exitDirs <> keyExitDirs <> exitsWith UnseenBoundary + drawFound = sequence_ + [ TM.drawGlyph win (CP.CPos (G.initWallSides + 4 + n) 1) gl + | n <- [0..B.treasuresPerBoard-1] + , let gl = maybe ((if n == B.treasuresPerBoard - 1 then bold else char) '?') + itemGlyph $ B.found bd `atMay` n + ] data HSInfo = HSRank Int @@ -461,20 +540,25 @@ centre style y s | y >= scrH = pure () | otherwise = TM.drawStr win style (CP.CPos ((scrW - length s) `div` 2) y) s + centreStyled y ss + | y >= scrH = pure () + | otherwise = drawStyledStrs win (CP.CPos ((scrW - sum (length . fst <$> ss)) `div` 2) y) ss drawTitle = sequence_ [ drawStyledStrs win (CP.CPos titleX y) s | (y,s) <- - [ (0, [ ("·──·──·──·", bdSt), (" ", bgSt) ]) + [ (0, [ ("┌────────┐", bdSt), (" ", bgSt) ]) , (1, [ ("│", bdSt), (" Fe@r of", styleBold) , ("│", bdSt), ("View ", bgSt) ]) - , (2, [ ("·──· ·──·", bdSt), (" ", bgSt) ]) + , (2, [ ("└─── ───┘", bdSt), (" ", bgSt) ]) ] ] where titleX = (scrW - length "| Fe@r of|View") `div` 2 bdSt = CStyle yellow True bgSt = CStyle (onBlue white) True + drawVersion = TM.drawStr win style0 (CP.CPos 0 $ scrH-1) $ "v" <> CURRENT_PACKAGE_VERSION wonStyle = CStyle magenta True ascii <- TM.asciiOnly + isBear <- TM.isBear let drawHS :: TM.TermM m => Bool -> Int -> HSInfo -> HS.Highscore -> m () drawHS showName y info hs = @@ -495,25 +579,35 @@ , (" ", style0) , (twoCharNum (HS.maxRound hs) <> ":", style0) , let lev = HS.maxLevel hs in (showLevel lev, levelStyle lev) + , (" ", style0) + , let n = HS.gems hs in (twoCharNum n <> "*", CStyle magenta False) + , (" ", style0) ] <> - [ (" ", style0) ] <> [ if e `elem` HS.equipment hs then (take 1 $ show e, equipStyle e) else ("-", style0) | e <- allEquipment ] - scoreX showName = min ((scrW - l) `div` 2) (scrW - l - 1 - aKeyL) - where l = sum $ [length "99 99~ 99:C"] + scoreX showName = min ((scrW - l) `div` 2) (scrW - l - 2 - aKeyL) + where l = sum $ [length "99 99~ 99:C 99*"] <> [11 | showName] <> [2 + length allEquipment] additionalKeys = [ " More keys:" ] <> [ "T: Hints" | T.TMeta `S.notMember` G.unseenBeats game ] <> [ "-: " <> "ASCII " <> (if ascii then "[x]" else "[ ]") , "Q: Exit" ] + <> concat [ + [ "─────────────" + , "Alt + Enter:" + , " Fullscreen" + , "Alt + -/+:" + , " Zoom" + ] | isBear ] aKeyL = maximum $ length <$> additionalKeys let keysLine y = centre style0 y "Keys: cursors / WASD / HJKL; 0-9" drawTitle + drawVersion if HS.maxRound curHs > 1 then do centre styleBold 3 "Game in progress:" @@ -527,18 +621,35 @@ drawHS False 4 info prev centre styleBold 6 "Press Space to start new game" Nothing -> centre styleBold 4 "Press Space to start" - keysLine 7 hss <- liftIO HSF.get + let recent = G.showRecentHS game + let ourHSs = filter ((== HS.name curHs) . HS.name) hss + let avOver = 10 + if length ourHSs < avOver + then keysLine 7 + else + let (avd,avm) = (`divMod` avOver) . sum $ HS.score <$> take avOver ourHSs + in centreStyled 7 + [ (show avOver <> " game average: ", style0) + , (show avd <> "." <> show avm <> "~ ", scoreStyle) + , ("R: " <> if recent then "Hide" else "Show", CStyle (onBlue white) False) + ] + unless (null hss) $ do let someNamed = any (isJust . HS.name) hss + showHss + | recent = ourHSs + | otherwise = HS.sort hss + drawStyledStrs win (CP.CPos (scoreX someNamed - 1) 9) $ - [ ("Rank ", styleBold) ] <> + [ (if recent then "Last " else "Rank ", styleBold) ] <> [ (" Name ", CStyle cyan True) | someNamed ] <> [ ("Score ", scoreStyle) , ("Level ", style0) + , ("Gems ", CStyle magenta False) , ("Equip", style0) ] - sequence_ [ drawHS someNamed (10+i) (HSRank $ 1+i) hs | (i,hs) <- zip [0..] hss ] + sequence_ [ drawHS someNamed (10+i) (HSRank $ 1+i) hs | (i,hs) <- zip [0..9] showHss ] sequence_ [ TM.drawStr win (CStyle (onBlue white) $ n == 0) @@ -548,22 +659,22 @@ tutBox :: T.Beat -> Maybe (CP.CPos, [Glyph]) tutBox = tutBox' where - tutBox' (T.Movement p) = Just (boardOffset <> posCPosL p, [creatureGlyph Player]) - tutBox' (T.Trapped p) = Just (boardOffset <> posCPosL p, [creatureGlyph Player]) + tutBox' (T.Movement p lf) = Just (boardOffset <> posCPosL p, [creatureGlyph $ Player lf]) + tutBox' (T.Trapped p lf) = Just (boardOffset <> posCPosL p, [creatureGlyph $ Player lf]) tutBox' (T.SeeMonster p c) = Just (boardOffset <> posCPosL p, [creatureGlyph c]) - tutBox' (T.SeeExit wp) = Just (boardOffset <> wposCPos wp, [bold . exitChar $ P.exitDir wp]) + tutBox' (T.SeeExit wp) = Just (boardOffset <> wposCPos wp, [bold . exitChar True $ P.exitDir wp]) + tutBox' (T.MustBreak wp) = Just (boardOffset <> wposCPos wp, [bold . exitChar True $ P.exitDir wp]) tutBox' (T.SeeItem p i) = Just (boardOffset <> posCPosR p, [itemGlyph i]) tutBox' (T.SeePotion p) = Just (boardOffset <> posCPosR p, [itemGlyph Potion]) - tutBox' (T.SeeMiniPotion p) = Just (boardOffset <> posCPosR p, [itemGlyph MiniPotion]) tutBox' (T.SeeScore p) = Just (boardOffset <> posCPosR p, [itemGlyph ScoreTreasure]) tutBox' (T.SeeJunk p) = Just (boardOffset <> posCPosR p, [itemGlyph Junk]) - tutBox' (T.SeeGem p) = Just (boardOffset <> posCPosR p, [itemGlyph Gem]) + tutBox' (T.SeeGem p) = Just (boardOffset <> posCPosR p, [itemGlyph . Gem $ B.powerTypeAt p]) tutBox' T.CollectItem = Just (invOffset <> CP.CPos 0 1, [char '1']) - tutBox' T.CollectGem = Just (invOffset <> CP.CPos 0 10, [Glyph '0' $ CStyle red True]) - tutBox' T.CollectScore = Just (statusOffset <> CP.CPos 20 1, (char <$> (" 1/" <> show G.maxScore)) <> [Glyph '~' scoreStyle]) - tutBox' (T.Hurt l ml) = Just (statusOffset <> CP.CPos 6 1, char <$> twoCharNum l <> "/" <> show ml) - tutBox' T.Timer = Just (levelInfoOffset <> CP.CPos (G.initCreatureSides - 4) 0, char <$> "- ]") - tutBox' T.SecondRound = Just (levelInfoOffset <> CP.CPos 0 2, char <$> "On exit:") + tutBox' (T.CollectGem pTp) = Just (invOffset <> CP.CPos 0 10, [Glyph '0' $ powerStyle pTp]) + tutBox' T.CollectScore = Just (statusOffset <> CP.CPos 21 1, (char <$> ("1/" <> show G.maxScore)) <> [Glyph '~' scoreStyle]) + tutBox' (T.Hurt l ml) = Just (statusOffset <> CP.CPos 7 1, char <$> show l <> "/" <> show ml) + tutBox' T.Timer = Just (levelInfoOffset <> CP.CPos (G.initWallSides - 5) 1, replicate 5 delSideGlyph) + --tutBox' T.MustBreak = Just (levelInfoOffset <> CP.CPos 0 2, char <$> "Seal:") tutBox' _ = Nothing winOffset win = CP.CPos x y where WinDim x y _ _ = geometry M.! win boardOffset = winOffset BoardWin diff --git a/TermM.hs b/TermM.hs --- a/TermM.hs +++ b/TermM.hs @@ -10,6 +10,8 @@ class MonadIO m => TermM m where drawStr :: Window -> CStyle -> CP.CPos -> String -> m () drawGlyph :: Window -> CP.CPos -> Glyph -> m () + drawCompositeGlyph :: Window -> CP.CPos -> CompositeGlyph -> m () wErase, wRefresh :: Window -> m () drawHighlightBoxChars :: CP.CPos -> [Glyph] -> m () asciiOnly :: m Bool + isBear :: m Bool diff --git a/Tutorial.hs b/Tutorial.hs --- a/Tutorial.hs +++ b/Tutorial.hs @@ -2,29 +2,29 @@ import Creature import Item +import qualified Power as Pow import qualified Pos as P data Beat = Meta | Meta2 - | Movement P.Pos - | Trapped P.Pos + | Movement P.Pos Int + | Trapped P.Pos Int | Hurt Int Int | CollectItem | CollectItem2 - | CollectGem + | CollectGem Pow.PowerType | CollectScore | SeeMonster P.Pos Creature | SeeItem P.Pos Item | SeePotion P.Pos - | SeeMiniPotion P.Pos | SeeScore P.Pos | SeeJunk P.Pos | SeeGem P.Pos | SeeExit P.WPos + | MustBreak P.WPos | Timer - | SecondRound | TutEnd deriving (Eq, Ord) @@ -37,41 +37,39 @@ | TSeeExit | TSeeItem | TSeePotion - | TSeeMiniPotion | TSeeScore | TSeeJunk | TSeeGem + | TMustBreak | TCollectItem | TCollectItem2 | TCollectGem | TCollectScore | THurt | TTimer - | TSecondRound | TTutEnd deriving (Eq, Ord, Enum, Bounded, Show) tp :: Beat -> Type -tp Meta = TMeta -tp Meta2 = TMeta2 -tp (Movement _) = TMovement -tp (Trapped _) = TTrapped -tp (SeeMonster _ _) = TSeeMonster -tp (SeeExit _) = TSeeExit -tp (SeeItem _ _) = TSeeItem -tp (SeePotion _) = TSeePotion -tp (SeeMiniPotion _) = TSeeMiniPotion -tp (SeeScore _) = TSeeScore -tp (SeeJunk _) = TSeeJunk -tp (SeeGem _) = TSeeGem -tp CollectItem = TCollectItem -tp CollectItem2 = TCollectItem2 -tp CollectGem = TCollectGem -tp CollectScore = TCollectScore -tp (Hurt _ _) = THurt -tp Timer = TTimer -tp SecondRound = TSecondRound -tp TutEnd = TTutEnd +tp Meta = TMeta +tp Meta2 = TMeta2 +tp (Movement _ _) = TMovement +tp (Trapped _ _) = TTrapped +tp (SeeMonster _ _) = TSeeMonster +tp (SeeExit _) = TSeeExit +tp (SeeItem _ _) = TSeeItem +tp (SeePotion _) = TSeePotion +tp (SeeScore _) = TSeeScore +tp (SeeJunk _) = TSeeJunk +tp (SeeGem _) = TSeeGem +tp (MustBreak _) = TMustBreak +tp CollectItem = TCollectItem +tp CollectItem2 = TCollectItem2 +tp (CollectGem _) = TCollectGem +tp CollectScore = TCollectScore +tp (Hurt _ _) = THurt +tp Timer = TTimer +tp TutEnd = TTutEnd allTypes :: [Type] allTypes = [minBound..maxBound] @@ -90,34 +88,32 @@ text' TTrapped = "Trapped! You can't rest, but can walk into a wall." text' TSeeMonster = - "That's something you'd rather not see..." + "Something you'd rather not see, still less touch." text' TSeeExit = "You found the way out of here, at last." + text' TMustBreak = + "You must break the seal, despite the consequences." text' TSeeItem = "Why are things always in the last place you look?" text' TSeePotion = - "That looks very refreshing." - text' TSeeMiniPotion = - "That looks quite refreshing." + "A drink? That would make you feel better." text' TSeeScore = - "This is just what you're looking for." + "These are just what you're looking for." text' TSeeJunk = "A load of junk. Maybe you could salvage something." text' TSeeGem = - "That looks powerful." + "You think you see a shining gemstone." text' TCollectItem = - "An item! Hit 1 then a direction to try to use it;" + "An item! Hit 1 then a direction to try to use it." text' TCollectItem2 = - "experiment to learn how to use each kind of item." + "Experiment to learn how to use each kind of item." text' TCollectGem = - "Press 0 to activate the power here." + "The gem released a power. Press 0 to activate it." text' TCollectScore = "Enough of these, and you can get out of here!" text' THurt = - "That hurt! Watch where you walk." + "Watch where you walk." text' TTimer = - "It gets more dangerous here the longer you stay." - text' TSecondRound = - "Levels get harder based on which way you leave." + "You feel the walls closing in." text' TTutEnd = "That was the last hint. You're on your own now." diff --git a/Wall.hs b/Wall.hs --- a/Wall.hs +++ b/Wall.hs @@ -17,7 +17,7 @@ wallDestructionCost :: Wall -> Maybe Int wallDestructionCost Hedge = Nothing wallDestructionCost BrokenWindow = Nothing -wallDestructionCost (CloakWall _ _) = Nothing +wallDestructionCost (CloakWall _ _) = Just 0 wallDestructionCost Window = Just 0 wallDestructionCost TentWall = Just 0 wallDestructionCost (UmbrellaWall _) = Just 0 diff --git a/fearOfView.cabal b/fearOfView.cabal --- a/fearOfView.cabal +++ b/fearOfView.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: fearOfView -version: 0.1.1.0 +version: 0.2.0.0 license: AGPL-3.0-or-later license-file: COPYING maintainer: mbays@sdf.org @@ -10,7 +10,7 @@ description: A constrained roguelike ("broughlike") game played on a 5x5 grid of cells which are regenerated when out of view. Can be compiled for play on a - genuine colour terminal using ncurses, or in a pseudo-terminal using + genuine colour terminal using ncurses, or in graphics mode using bearlibterminal. category: Game extra-doc-files: CHANGELOG.md README.md fov-shot.png @@ -41,17 +41,20 @@ Board BoardConf Command + CommonUI Creature CPos CStyle Equipment Exit Inventory + Fov Game GameName Geometry Group Highscore + HighscoreV1 HighscoreFile Item KeyBindings diff --git a/fov-shot.png b/fov-shot.png Binary files a/fov-shot.png and b/fov-shot.png differ