fearOfView 0.1.1.0 → 0.2.0.0
raw patch · 30 files changed
+1015/−544 lines, 30 files
Files
- BearUI.hs +22/−24
- BearUIMInstance.hs +26/−6
- Board.hs +302/−153
- BoardConf.hs +12/−16
- CHANGELOG.md +22/−0
- CStyle.hs +12/−3
- Command.hs +2/−2
- CommonUI.hs +20/−0
- Creature.hs +18/−13
- CursesUI.hs +37/−23
- CursesUIMInstance.hs +1/−1
- Equipment.hs +1/−5
- Exit.hs +2/−2
- Fov.hs +39/−0
- Game.hs +131/−97
- Geometry.hs +2/−2
- Highscore.hs +12/−5
- HighscoreFile.hs +11/−6
- HighscoreV1.hs +19/−0
- Item.hs +9/−8
- KeyBindings.hs +16/−5
- Pos.hs +6/−0
- RollFrom.hs +2/−0
- Serialise.hs +6/−0
- TermDraw.hs +241/−130
- TermM.hs +2/−0
- Tutorial.hs +36/−40
- Wall.hs +1/−1
- fearOfView.cabal +5/−2
- fov-shot.png binary
BearUI.hs view
@@ -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
BearUIMInstance.hs view
@@ -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 }
Board.hs view
@@ -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
BoardConf.hs view
@@ -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
CHANGELOG.md view
@@ -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
CStyle.hs view
@@ -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
Command.hs view
@@ -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)
+ CommonUI.hs view
@@ -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) '─' <> "┘")
Creature.hs view
@@ -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
CursesUI.hs view
@@ -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
CursesUIMInstance.hs view
@@ -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
Equipment.hs view
@@ -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
Exit.hs view
@@ -1,8 +1,8 @@ module Exit where data Exit- = Exit- | KeyExit+ = Exit Bool+ | KeyExit Bool | Entrance | UnseenBoundary | SeenBoundary
+ Fov.hs view
@@ -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
Game.hs view
@@ -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'
Geometry.hs view
@@ -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)
Highscore.hs view
@@ -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
HighscoreFile.hs view
@@ -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
+ HighscoreV1.hs view
@@ -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]
Item.hs view
@@ -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
KeyBindings.hs view
@@ -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
Pos.hs view
@@ -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'
RollFrom.hs view
@@ -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
Serialise.hs view
@@ -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
TermDraw.hs view
@@ -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
TermM.hs view
@@ -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
Tutorial.hs view
@@ -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."
Wall.hs view
@@ -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
fearOfView.cabal view
@@ -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
fov-shot.png view
binary file changed (7238 → 54009 bytes)