fearOfView 0.1.0.3 → 0.1.1.0
raw patch · 15 files changed
+1011/−666 lines, 15 filesdep +bearlibterminaldep ~basebinary-added
Dependencies added: bearlibterminal
Dependency ranges changed: base
Files
- BearUI.hs +156/−0
- BearUIMInstance.hs +63/−0
- CHANGELOG.md +3/−0
- CStyle.hs +4/−9
- CursesDraw.hs +0/−585
- CursesUI.hs +23/−20
- CursesUIMInstance.hs +17/−22
- Geometry.hs +38/−0
- Main.hs +57/−22
- README.md +4/−0
- TermDraw.hs +575/−0
- TermM.hs +15/−0
- VeraMoBd.ttf binary
- Window.hs +14/−0
- fearOfView.cabal +42/−8
+ BearUI.hs view
@@ -0,0 +1,156 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}++module BearUI where++import Control.Monad (void)+import Control.Monad.State (StateT, gets, liftIO)+import Data.Char (chr, ord)++import qualified BearLibTerminal as B+import BearLibTerminal.Keycodes ()+import qualified Data.Map.Strict as M++import CStyle+import Geometry+import Window++import qualified CPos as CP+import qualified KeyBindings as KB+import qualified TermM as TM++data UIState = UIState+ { uiKeyBindings :: KB.KeyBindings+ , asciiOnly :: Bool+ }+type UIM = StateT UIState IO+nullUIState :: UIState+nullUIState = UIState [] False++getWin :: Window -> WinDim+getWin win = M.findWithDefault (WinDim 0 0 0 0) win geometry++getBindings :: UIM KB.KeyBindings+getBindings = gets $ (<> KB.defaultBindings) . uiKeyBindings++charify :: B.Keycode -> Maybe Char+charify key = case key of+ B.TkBackspace -> Just '\b'+ B.TkLeft -> Just '←'+ B.TkRight -> Just '→'+ B.TkDown -> Just '↓'+ B.TkUp -> Just '↑'+ B.TkMinus -> Just '-'+ B.TkEscape -> Just '\ESC'+ B.TkSpace -> Just ' '+ B.TkReturn -> Just '\r'+ B.TkEnter -> Just '\n'+ 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))+ B.TkKp0 -> Just '0'+ c | B.TkKp1 <= c && c <= B.TkKp9 -> Just $ chr (ord '1' + (fromEnum c - fromEnum B.TkKp1))+ _ -> Nothing++wSetStyle :: Window -> CStyle -> UIM ()+wSetStyle _ (CStyle col b) = do+ let (bg,fg) = col `divMod` 8+ liftIO . B.terminalColorUInt $ colour fg b+ liftIO . B.terminalBkColorUInt $ colour (bgTrans bg) False+ where+ bgTrans :: Int -> Int+ bgTrans 1 = 4 -- blue+ bgTrans 2 = 1 -- red+ bgTrans 3 = 5 -- magenta+ bgTrans _ = 7 -- black+ colour c False = case c of+ 0 -> 0xffafafaf -- grey+ 1 -> 0xffaf0000 -- red+ 2 -> 0xff00af00 -- green+ 3 -> 0xffafaf00 -- yellow+ 4 -> 0xff0000af -- blue+ 5 -> 0xffaf008f -- magenta+ 6 -> 0xff00afaf -- cyan+ _ -> 0xff000000 -- black+ colour c True = case c of+ 0 -> 0xffffffff -- white+ 1 -> 0xffff0000 -- bold red+ 2 -> 0xff00ff00 -- bold green+ 3 -> 0xffffff00 -- bold yellow+ 4 -> 0xff0000ff -- 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+ liftIO $ B.terminalLayer 1+ sub <- gets $ subCharAscii . asciiOnly+ 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) '═' <> "╝"+ p' = p <> CP.CPos (-1) (-1)+++drawStr :: Window -> CStyle -> CP.CPos -> String -> UIM ()+drawStr w style (CP.CPos x y) s = do+ sub <- gets $ subCharAscii . asciiOnly+ let WinDim dx dy _ _ = getWin w+ withStyle w style . liftIO $ drawStrByChar (CP.CPos (x+dx) (y+dy)) (sub <$> s)++drawStrByChar :: CP.CPos -> String -> IO ()+drawStrByChar (CP.CPos x y) s =+ -- B.terminalPrintString seems to have problems with unicode chars,+ -- so use B.terminalPut instead.+ sequence_ [ B.terminalPut (x+dx) y ch | (dx,ch) <- zip [0..] s ]++drawGlyph :: Window -> CP.CPos -> Glyph -> UIM ()+drawGlyph w (CP.CPos x y) (Glyph ch style) = do+ sub <- gets $ subCharAscii . asciiOnly+ let WinDim dx dy _ _ = getWin w+ withStyle w style . liftIO $ B.terminalPut (x+dx) (y+dy) (sub ch)++erase :: UIM ()+erase = B.terminalClear++wErase, wRefresh :: Window -> UIM ()+wErase win = do+ let WinDim x y w h = getWin win+ void . liftIO $ B.terminalClearArea x y w h++wRefresh _ = liftIO B.terminalRefresh -- no per-win version++instance TM.TermM UIM where+ drawStr = drawStr+ drawGlyph = drawGlyph+ wErase = wErase+ wRefresh = wRefresh+ drawHighlightBoxChars = drawHighlightBoxChars+ asciiOnly = gets asciiOnly
+ BearUIMInstance.hs view
@@ -0,0 +1,63 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}++module BearUIMInstance where++import Control.Monad (forM_)+import Control.Monad.State (evalStateT, liftIO, modify)+import Data.Maybe (maybeToList)++import qualified BearLibTerminal as B++import BearUI+import Geometry++import qualified Game as G+import qualified TermDraw as TD+import qualified UIMonad as UIM++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 <> ";"+ 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+ pure $ b1 && b2+ endUI = liftIO B.terminalClose+ draw game = do+ 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+ forM_ (reverse $ G.transitions game) TD.drawTrans+ 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+ TD.drawStatus game+ TD.drawLevelInfo bd+ TD.drawMessage game+ case st of+ G.Tutorialising b -> TD.highlightTut b+ _ -> pure ()+ suspend = pure ()+ redraw = pure ()+ setAsciiOnly a = modify $ \s -> s { asciiOnly = a }+ toggleAsciiOnly = modify $ \s -> s { asciiOnly = not (asciiOnly s) }++ setUIBinding ch cmd = modify $ \s -> s { uiKeyBindings = (ch,cmd) : uiKeyBindings s }++ getChRaw = (charify <$>) . liftIO $ B.terminalRead+ getInput = UIM.getChRaw >>= \case+ Just ch -> maybeToList . lookup ch <$> getBindings+ _ -> pure []
CHANGELOG.md view
@@ -6,3 +6,6 @@ ## 0.1.0.3 -- 2025-08-12 * Fix incompatibility with recent GHC. Thanks Francesco Ariis. * Fix WASD keybindings++## 0.1.1.0 -- 2025-08-15+* Add bearlibterminal-based UI (enabled with -fbear)
CStyle.hs view
@@ -1,7 +1,5 @@ module CStyle where -import qualified UI.HSCurses.Curses as C- type ColPair = Int white,red,green,yellow,blue,magenta,cyan,black :: ColPair white = 0@@ -18,15 +16,12 @@ onRed = (+16) . (`mod` 8) onYellow = (+24) . (`mod` 8) -data CStyle = CStyle { cstyleCol :: ColPair, cstyleAttr :: C.Attr }-a0, aBold :: C.Attr-a0 = C.attr0-aBold = C.setBold a0 True+data CStyle = CStyle { cstyleCol :: ColPair, cstyleBold :: Bool } style0, styleBold :: CStyle-style0 = CStyle 0 a0-styleBold = CStyle 0 aBold+style0 = CStyle 0 False+styleBold = CStyle 0 True data Glyph = Glyph { glyphChar :: Char, glyphStyle :: CStyle } modColour :: (ColPair -> ColPair) -> Glyph -> Glyph-modColour f (Glyph c (CStyle col a)) = Glyph c (CStyle (f col) a)+modColour f (Glyph c (CStyle col b)) = Glyph c (CStyle (f col) b)
− CursesDraw.hs
@@ -1,585 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE TupleSections #-}--module CursesDraw where--import Control.Concurrent (threadDelay)-import Control.Monad (forM, forM_, mplus, unless, void)-import Control.Monad.State (get, gets, 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 Safe (atMay)--#if !MIN_VERSION_base(4,20,0)--- foldl' started being exported from prelude in base-4.20.0-import Data.Foldable (foldl')-#endif--import qualified Data.Map.Strict as M-import qualified Data.Set as S--import Creature-import CStyle-import Equipment-import Exit-import Group-import Item-import Wall--import qualified Board as B-import qualified BoardConf as BC-import qualified CPos as CP-import qualified CursesUI as CU-import qualified Game as G-import qualified Highscore as HS-import qualified HighscoreFile as HSF-import qualified Inventory as I-import qualified Pos as P-import qualified Power as Pow-import qualified RollFrom as RF-import qualified Tutorial as T--scrW,scrH :: Int-scrW = 60-scrH = 20---- Can draw on board at CPos x y for x < w and y < h-w,h :: Int-w = B.w * 3 + 1-h = B.h * 2 + 1--invItemGlyph :: InvItem -> Glyph-invItemGlyph e = Glyph c $ CStyle cyan aBold where- c = case e of- Orb -> 'o'- Cloak -> '['- Umbrella -> '/'- Balloon _ -> '&'- Flash -> '='- Camera _ -> ')'- Tent -> 'A'- Spraypaint _ -> ':'--drawStyledStrs :: CU.Window -> CP.CPos -> [(String, CStyle)] -> CU.UIM ()-drawStyledStrs win (CP.CPos x0 y) = void . (`runStateT` x0) . mapM draw where- draw (s,style) = do- x <- get- lift $ CU.drawStr win style (CP.CPos x y) s- put $ x + length s--twoCharNum :: Int -> String-twoCharNum n | 0 <= n && n < 10 = ' ' : show n- | otherwise = take 2 $ show n--drawStatus :: G.Game -> CU.UIM ()-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- let win = CU.StatusWin- unless (M.null statuses) $ drawStyledStrs win (CP.CPos 0 0) statusStrs- drawStyledStrs win (CP.CPos 0 1) numStrs- where- -- XXX: keep in sync with magic numbers in highlightTut- numStrs =- [ ("Life: ", style0)- , (twoCharNum life, lifeStyle)- , ("/", 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)- , ("%", junkStyle)- ]- lifeStyle = case life of- n | n <= 0 -> CStyle (onRed black) aBold- 1 -> CStyle red aBold- 2 -> CStyle red a0- 3 -> CStyle yellow aBold- 4 -> CStyle yellow a0- 5 -> style0- 6 -> CStyle green a0- _ -> CStyle green aBold- statusStrs = intersperse (" ", style0)- [ (show (fst status) <> " " <> twoCharNum (snd status), statStyle status)- | status <- M.assocs statuses ]- statStyle (B.Dazzled,_) = CStyle cyan aBold- statStyle (B.Ghost,_) = style0- statStyle (B.Smoke,_) = CStyle blue aBold- statStyle (B.Haste,n) = CStyle (if n `mod` 2 == 1 then red else yellow) aBold- statStyle (B.Foresight,_) = styleBold--exitChar :: P.Dir -> Char-exitChar = \case- P.DUp -> '^'- P.DDown -> 'v'- P.DRight -> '>'- P.DLeft -> '<'--drawBoard :: B.Board -> CU.UIM ()-drawBoard = drawAlertedBoard . baseAlerted--data AlertedBoard = AlertedBoard- { base :: B.Board- , creatureMoves :: M.Map P.WPos Creature- , itemMoves :: M.Map P.WPos Item- , itemUses :: M.Map P.WPos Item- , highlightPs :: S.Set P.Pos- , highlightWPs :: S.Set P.WPos- }-baseAlerted :: B.Board -> AlertedBoard-baseAlerted bd = AlertedBoard bd M.empty M.empty M.empty S.empty S.empty--drawTrans :: B.Transition -> CU.UIM ()-drawTrans (B.Transition bd0 alerts) =- let alerted = foldl' applyAlert (baseAlerted bd0) alerts- in do- drawAlertedBoard alerted- CU.wRefresh CU.BoardWin- CU.wErase CU.BoardWin- liftIO (threadDelay 50000)- where- applyAlert alerted (B.AlertMoveCreature c p d) =- alerted { creatureMoves = M.insert (P.wposInDir p d) c $ creatureMoves alerted- , base = B.modCreatures (M.delete p) $ 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- }- applyAlert alerted (B.AlertUseItem i p d) =- alerted { itemUses = M.insert (P.wposInDir p d) i $ itemUses alerted- , base = B.modItems (M.delete p) $ base alerted- }- applyAlert alerted (B.AlertHighlight ps wps) =- alerted { highlightPs = ps `S.union` highlightPs alerted- , highlightWPs = wps `S.union` highlightWPs alerted- }--char,bold,dim :: Char -> Glyph-char c = Glyph c style0-bold c = Glyph c styleBold-dim c = Glyph c $ CStyle (onBlue white) a0--levelStyle :: Int -> CStyle-levelStyle 1 = CStyle green a0-levelStyle 2 = CStyle white aBold-levelStyle 3 = CStyle yellow aBold-levelStyle _ = style0--showLevel :: Int -> String-showLevel l | l > 0 = (['A'..] !! (l-1)):""-showLevel _ = "-"--scoreStyle, junkStyle :: CStyle-scoreStyle = CStyle yellow a0-junkStyle = CStyle blue aBold--creatureGlyph :: Creature -> Glyph-creatureGlyph Player = bold '@'-creatureGlyph DeadPlayer = Glyph '@' $ CStyle (onRed black) aBold-creatureGlyph BasicMonster = Glyph 'm' $ CStyle yellow a0-creatureGlyph CalmMonster = Glyph 'p' $ CStyle blue aBold-creatureGlyph ChaseMonster = Glyph 'c' $ CStyle yellow aBold-creatureGlyph GhostMonster = Glyph 'g' $ CStyle white aBold-creatureGlyph SmartMonster = Glyph 's' $ CStyle red aBold-creatureGlyph (InflatedBalloon charges) = Glyph '0' . CStyle magenta $ if charges > 0 then aBold else a0--itemGlyph :: Item -> Glyph-itemGlyph Gem = Glyph '*' $ CStyle green aBold-itemGlyph Potion = Glyph '!' $ CStyle green aBold-itemGlyph MiniPotion = Glyph '!' $ CStyle green a0-itemGlyph ScoreTreasure = Glyph '~' scoreStyle-itemGlyph Junk = Glyph '%' junkStyle-itemGlyph (UmbrellaHandle d) = Glyph (if d `elem` [P.DUp, P.DDown] then '|' else '-') $ CStyle magenta aBold-itemGlyph CameraBoxed = Glyph ')' $ CStyle cyan a0-itemGlyph (RollingOrb _ _) = Glyph 'o' $ CStyle cyan a0-itemGlyph (ItemInvItem e) = invItemGlyph e--wallGlyphVert :: Wall -> Glyph-wallGlyphVert = \case- BasicWall -> bold wallchar- Pillar -> char '|'- Hedge -> Glyph wallchar $ CStyle green aBold- ThickHedge -> Glyph '║' $ CStyle green a0- Window -> Glyph wallchar $ CStyle cyan a0- BrokenWindow -> Glyph ';' $ CStyle cyan a0- (CloakWall _ _) -> Glyph wallchar $ CStyle cyan aBold- (UmbrellaWall d) -> Glyph (if d == P.DRight then '>' else '<') $ CStyle magenta aBold- TentWall -> Glyph wallchar $ CStyle red aBold- where wallchar = '│'--wallGlyphHoriz :: Wall -> (Glyph,Glyph)-wallGlyphHoriz = \case- Pillar -> (char '-', char '-')- (UmbrellaWall P.DUp) -> (umb '/', umb '\\')- (UmbrellaWall _) -> (umb '\\', umb '/')- BasicWall -> doublet $ bold wallchar- Hedge -> doublet . Glyph wallchar $ CStyle green aBold- ThickHedge -> doublet . Glyph '═' $ CStyle green a0- Window -> doublet . Glyph wallchar $ CStyle cyan a0- BrokenWindow -> (Glyph '.' $ CStyle cyan a0 , Glyph ',' $ CStyle cyan a0)- (CloakWall _ _) -> doublet . Glyph wallchar $ CStyle cyan aBold- TentWall -> doublet . Glyph wallchar $ CStyle red aBold- where- wallchar = '─'- umb c = Glyph c $ CStyle magenta aBold- doublet gl = (gl,gl)--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 '.'- 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 '.'- SeenBoundary -> doublet $ Glyph '─' st- where doublet gl = (gl,gl)---- positions in board window-posCPosL, posCPosR, posIntCPos :: P.Pos -> CP.CPos-posCPosL (P.Pos x y) = CP.CPos (3*(x+1) - 2) $ 2*(B.h - y) - 1-posCPosR = (CP.CPos 1 0 <>) . posCPosL-posIntCPos p = posCPosL p <> CP.CPos 2 (-1)-wposCPos, wposCPosR :: P.WPos -> CP.CPos-wposCPos (P.WPos p up) = posCPosL p <> if up then CP.CPos 0 (-1) else CP.CPos 2 0-wposCPosR = (CP.CPos 1 0 <>) . wposCPos--drawAlertedBoard :: AlertedBoard -> CU.UIM ()-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- 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- filterV = M.filterWithKey $ const . not . P.up- filterH = M.filterWithKey $ const . P.up- filterSV = S.filter $ not . P.up- filterSH = S.filter P.up- 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- bdWallsV = glyphsV (const wallGlyphVert) $ B.walls bd- bdWallsH = glyphsH (const wallGlyphHoriz) $ B.walls bd- 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.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 aBold- _ | Pow.overUsable pow -> equipStyle Siphon- _ -> style0- creatures = (,Nothing) . Just . creatureGlyph' <$> B.creatures bd- creatureGlyph' Player = Glyph '@' $ CStyle col a where- col | B.isHasteRound bd = red- | B.hasted bd = yellow- | otherwise = white- a | B.ghostly bd = a0- | otherwise = aBold- 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- expectChar p- | B.expectant bd- , Just (Just c) <- B.expected bd M.!? p = glyphChar $ creatureGlyph' c- | otherwise = ' '- obsChar p- | p `S.member` B.unrevealed bd = expectedTreasureChar p- | otherwise = ' '- expectedTreasureChar = glyphChar . itemGlyph . B.treasureAt bd- wObscuredV = M.fromSet (const $ dim ' ') . filterSV $ obscuredWPoss- wObscuredH = M.fromSet (const . biGlyph $ dim ' ') . filterSH $ obscuredWPoss- obscuredWPoss = B.invisibleWPoss (B.tagged bd) (B.visible bd)- mvingV = M.map creatureGlyph' (filterV cmvs) `M.union` M.map itemGlyph (filterV $ imvs `M.union` iuses)- mvingH = M.map ((,Nothing) . Just . creatureGlyph') (filterH cmvs)- `M.union` M.map ((Nothing,) . Just . itemGlyph) (filterH imvs)- `M.union` M.map ((,Nothing) . Just . itemGlyph) (filterH iuses)- highlightCells = M.fromSet (const . biGlyph $ bold '#') hps- highlightV = M.fromSet (const $ bold '#') $ filterSV hwps- 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) ]- where- wallI BasicWall = Just $ CStyle white aBold- wallI Hedge = Just $ CStyle green aBold- wallI ThickHedge = Just $ CStyle green a0- wallI Pillar = Nothing- wallI Window = Nothing- wallI BrokenWindow = Nothing- wallI (UmbrellaWall _) = Nothing- wallI (CloakWall _ _) = Just $ CStyle cyan aBold- wallI TentWall = Just $ CStyle red aBold- 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-- 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)- horizWCPosMap :: M.Map P.WPos (Maybe Glyph, Maybe Glyph) -> M.Map CP.CPos Glyph- horizWCPosMap m = M.mapMaybe fst (M.mapKeys wposCPos m) `M.union` M.mapMaybe snd (M.mapKeys wposCPosR m)-- glyphs :: M.Map CP.CPos Glyph- glyphs = M.unions- [ horizCPosMap cells- , M.mapKeys wposCPos wallsV- , horizWCPosMap wallsH- , M.mapKeys posIntCPos intersections- ]- in do- sequence_ $ M.mapWithKey (CU.drawGlyph CU.BoardWin) glyphs--drawInv :: Maybe I.Slot -> Int -> Bool -> I.Inventory -> Maybe Pow.Power -> CU.UIM ()-drawInv sel preserve highlightEmpty (I.Inventory inv) pow = do- let win = CU.InvWin- let str x y st = CU.drawStr win st (CP.CPos x y)- str 0 0 styleBold "Inventory:"- sequence_ $- [ do- str 0 slot style (show slot)- case me of- Nothing -> pure ()- Just e -> do- CU.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 attr where- col | slot <= preserve = yellow- | highlightEmpty && isNothing me = red- | otherwise = white- attr | sel == Just slot = aBold- | otherwise = a0- ] <>- [ 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 $ if charges > 0 then aBold else a0- ]--equipStyle :: Equipment -> CStyle-equipStyle Bag = CStyle yellow a0-equipStyle Charm = CStyle green aBold-equipStyle GrabHand = CStyle red a0-equipStyle Key = CStyle blue aBold-equipStyle Siphon = CStyle yellow aBold--drawEquip :: S.Set Equipment -> CU.UIM ()-drawEquip es | S.null es = pure ()-drawEquip es = do- let win = CU.EquipWin- let str x y st = CU.drawStr win st (CP.CPos x y)- str 0 0 styleBold "Equipment:"- forM_ (zip [1..] (S.toList es)) $ \(y,e) ->- str 0 y (equipStyle e) $ show e--drawMessage :: G.Game -> CU.UIM ()-drawMessage game = do- let win = CU.MessageWin- (text,style) = case G.playState game of- G.Dead -> ("You died with " <> show (G.score game) <>- " points on level " <> show (G.round game) <>- ":" <> showLevel (G.level game) <> ". [Space]", styleBold)- G.Won -> ("Congratulations, you win! [Space]", styleBold)- G.Tutorialising b -> (T.text b <> " [Spc/T]", CStyle magenta aBold)- _ -> ("", style0)- CU.drawStr win style (CP.CPos 0 0) text--drawLevelInfo :: B.Board -> CU.UIM ()-drawLevelInfo bd = do- drawRoll 0 (BC.creatureRoll bc) G.initCreatureSides creatureGlyph- drawRoll 1 (BC.wallRoll bc) G.initWallSides wallGlyphVert- drawDiffsLine 2- where- win = CU.LevelInfoWin- nullGlyph = char '-'- drawRoll :: Int -> RF.RollFrom a -> Int -> (a -> Glyph) -> CU.UIM ()- drawRoll m roll initSides f = sequence_ $- [ CU.drawGlyph win (CP.CPos n m) $ maybe nullGlyph f (RF.vals roll `atMay` n)- | n <- [0 .. RF.sides roll - 1]- ] <> [ CU.drawGlyph win (CP.CPos initSides m) $ char ']' ]- bc = B.conf bd- diffs = B.diffs bd- drawDiffsLine y = CU.drawStr win style0 (CP.CPos 0 y) introStr >> sequence_- [ do- draw b . char' $ exitChar dir- draw (b+1) (char ':')- forM (zip [0..] rdfs) (\(x,rdf) -> draw (b+3+x) $ rdfGlyph rdf)- | (n,dir) <- zip [0..] P.dirs- , dir `elem` possibleExitDirs- , let b = length introStr + 8*n- , let char'- | dir `elem` exitDirs = bold- | dir `elem` keyExitDirs = \c -> Glyph c $ equipStyle Key- | otherwise = char- , Just rdfs <- [diffs M.!? dir]- ]- where- introStr = "On exit: "- draw x = CU.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- possibleExitDirs = exitDirs <> keyExitDirs <> exitsWith UnseenBoundary--data HSInfo- = HSRank Int- | HSAlive- | HSDead- | HSWon--drawMainScreen :: G.Game -> CU.UIM ()-drawMainScreen game = do- let win = CU.MainWin- curHs = twiddle $ G.highscore Nothing game where- twiddle hs = hs { HS.maxLevel = 0, HS.maxRound = HS.maxRound hs + 1 }- centre style y s- | y >= scrH = pure ()- | otherwise = CU.drawStr win style (CP.CPos ((scrW - length s) `div` 2) y) s- drawTitle = sequence_ [ drawStyledStrs win (CP.CPos titleX y) s- | (y,s) <-- [ (0, [ ("·──·──·──·", bdSt), (" ", bgSt) ])- , (1, [ ("│", bdSt), (" Fe@r of", styleBold)- , ("│", bdSt), ("View ", bgSt) ])- , (2, [ ("·──· ·──·", bdSt), (" ", bgSt) ])- ]- ] where- titleX = (scrW - length "| Fe@r of|View") `div` 2- bdSt = CStyle yellow aBold- bgSt = CStyle (onBlue white) aBold- wonStyle = CStyle magenta aBold-- ascii <- gets CU.asciiOnly-- let drawHS :: Bool -> Int -> HSInfo -> HS.Highscore -> CU.UIM ()- drawHS showName y info hs =- drawStyledStrs win (CP.CPos (scoreX showName) y) $- (case info of- HSRank rank -> [(twoCharNum rank, styleBold)]- HSAlive -> [(" @", styleBold)]- HSDead -> [(" ",style0), ("@", CStyle (onRed white) aBold)]- HSWon -> [(" ",style0), ("@", wonStyle)]- ) <>- [ (" ", style0)- ] <>- [ (take 8 (fromMaybe "[anon]" (HS.name hs) <> repeat ' ') <> " ", CStyle cyan aBold)- | showName- ] <>- [ (twoCharNum (HS.score hs) <> "~",- if HS.score hs == G.maxScore then wonStyle else scoreStyle)- , (" ", style0)- , (twoCharNum (HS.maxRound hs) <> ":", style0)- , let lev = HS.maxLevel hs in (showLevel lev, levelStyle lev)- ] <>- [ (" ", 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"]- <> [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" ]- aKeyL = maximum $ length <$> additionalKeys-- let keysLine y = centre style0 y "Keys: cursors / WASD / HJKL; 0-9"-- drawTitle- if HS.maxRound curHs > 1- then do- centre styleBold 3 "Game in progress:"- drawHS False 4 HSAlive curHs- centre styleBold 6 "Press Space to continue"- else case G.prevHS game of- Just prev -> do- centre style0 3 "Last game:"- let info | HS.score prev >= G.maxScore = HSWon- | otherwise = HSDead- 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- unless (null hss) $ do- let someNamed = any (isJust . HS.name) hss- drawStyledStrs win (CP.CPos (scoreX someNamed - 1) 9) $- [ ("Rank ", styleBold) ] <>- [ (" Name ", CStyle cyan aBold) | someNamed ] <>- [ ("Score ", scoreStyle)- , ("Level ", style0)- , ("Equip", style0) ]- sequence_ [ drawHS someNamed (10+i) (HSRank $ 1+i) hs | (i,hs) <- zip [0..] hss ]-- sequence_ [ CU.drawStr win- (CStyle (onBlue white) $ if n == 0 then aBold else a0)- (CP.CPos (scrW - 2 - aKeyL) $ 10 + n) . take aKeyL $ s <> repeat ' '- | (s,n) <- zip additionalKeys [0..]- ]--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.SeeMonster p c) = Just (boardOffset <> posCPosL p, [creatureGlyph c])- tutBox' (T.SeeExit wp) = Just (boardOffset <> wposCPos wp, [bold . exitChar $ 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.CollectItem = Just (invOffset <> CP.CPos 0 1, [char '1'])- tutBox' T.CollectGem = Just (invOffset <> CP.CPos 0 10, [Glyph '0' $ CStyle red aBold])- tutBox' T.CollectScore = Just (statusOffset <> CP.CPos 20 0, (char <$> (" 1/" <> show G.maxScore)) <> [Glyph '~' scoreStyle])- tutBox' (T.Hurt l ml) = Just (statusOffset <> CP.CPos 6 0, 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' _ = Nothing- boardOffset = CP.CPos 1 3- invOffset = CP.CPos (1+w+2) 3- statusOffset = CP.CPos 0 1- afterBoard = 3 + max h (3 + length I.slots)- levelInfoOffset = CP.CPos 1 (1 + afterBoard)--highlightTut :: T.Beat -> CU.UIM ()-highlightTut = maybe (pure ()) (uncurry CU.drawHighlightBoxChars) . tutBox
CursesUI.hs view
@@ -1,5 +1,6 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-} module CursesUI where @@ -12,22 +13,11 @@ import qualified UI.HSCurses.Curses as C import CStyle+import Window import qualified CPos as CP import qualified KeyBindings as KB--data Window- = MainWin- | StatusWin- | BoardWin- | InvWin- | EquipWin- | LevelInfoWin- | MessageWin- | TutorialWin- deriving (Eq,Ord,Enum,Bounded)-allWindows :: [Window]-allWindows = [minBound..maxBound]+import qualified TermM as TM data UIState = UIState { dispCPairs :: [C.Pair]@@ -90,7 +80,7 @@ setBkgrnd :: UIM () setBkgrnd = do cpairs <- gets dispCPairs- liftIO . C.bkgrndSet a0 $ cpairs !! white+ liftIO . C.bkgrndSet C.attr0 $ cpairs !! white liftIO $ C.erase >> C.refresh wsetBkgrnd :: Window -> UIM ()@@ -99,17 +89,21 @@ wsetBkgrnd w = do cpairs <- gets dispCPairs cw <- getWin w- liftIO . C.wbkgrndSet cw a0 $ cpairs !! white+ liftIO . C.wbkgrndSet cw C.attr0 $ cpairs !! white liftIO $ C.werase cw >> C.wRefresh cw #else wsetBkgrnd _ = pure () #endif +attrOfBold :: Bool -> C.Attr+attrOfBold False = C.attr0+attrOfBold True = C.setBold C.attr0 True+ wSetStyle :: Window -> CStyle -> UIM ()-wSetStyle w (CStyle col attr) = do+wSetStyle w (CStyle col b) = do cpairs <- gets dispCPairs cw <- getWin w- liftIO $ C.wAttrSet cw (attr, cpairs!!col)+ liftIO $ C.wAttrSet cw (attrOfBold b, cpairs!!col) withStyle :: Window -> CStyle -> (UIM a -> UIM a) withStyle w style m = wSetStyle w style >> (m <* wSetStyle w style0) @@ -136,7 +130,7 @@ let w = 2 + length gls insWin TutorialWin =<< liftIO (C.newWin 3 w (y-1) (x-1)) ascii <- gets asciiOnly- withStyle TutorialWin (CStyle magenta aBold) $ liftIO . drawBorder ascii (3,w) =<< getWin TutorialWin+ withStyle TutorialWin (CStyle magenta True) $ liftIO . drawBorder ascii (3,w) =<< getWin TutorialWin sequence_ [ drawGlyph TutorialWin (CP.CPos (1+n) 1) gl | (gl,n) <- zip gls [0..] ] where -- Draw border manually rather than using C.wBorder:@@ -165,3 +159,12 @@ wErase w = liftIO . C.werase =<< getWin w wRefresh w = liftIO . C.wRefresh =<< getWin w wnoutRefresh w = liftIO . C.wnoutRefresh =<< getWin w++instance TM.TermM UIM where+ drawStr = drawStr+ drawGlyph = drawGlyph+ wErase = wErase+ wRefresh = wRefresh+ drawHighlightBoxChars = drawHighlightBoxChars+ asciiOnly = gets asciiOnly+
CursesUIMInstance.hs view
@@ -11,17 +11,19 @@ import Data.List ((\\)) import Data.Maybe (isJust, maybeToList) +import qualified Data.Map.Strict as M import qualified UI.HSCurses.Curses as C import qualified UI.HSCurses.CursesHelper as CH import CStyle import CursesUI+import Geometry+import Window import qualified Command as Cmd import qualified CPos as CP-import qualified CursesDraw as CD import qualified Game as G-import qualified Inventory as I+import qualified TermDraw as TD import qualified UIMonad as UIM instance UIM.UIMonad UIM where@@ -37,15 +39,8 @@ ] modify $ \s -> s {dispCPairs = cpairs} setBkgrnd- insWin StatusWin =<< liftIO (C.newWin 2 CD.scrW 0 0)- insWin BoardWin =<< liftIO (C.newWin CD.h (CD.w+1) 3 1)- insWin InvWin =<< liftIO (C.newWin (3 + length I.slots) 20 3 (1+CD.w+3))- insWin EquipWin =<< liftIO (C.newWin (3 + length I.slots) 15 3 (1+CD.w+3+20))- let afterBoard = 3 + max CD.h (3 + length I.slots)- insWin LevelInfoWin =<< liftIO (C.newWin 3 CD.scrW (1 + afterBoard) 1)- insWin MessageWin =<< liftIO (C.newWin 1 CD.scrW (1 + 3 + 1 + afterBoard) 0)- insWin MainWin =<< liftIO (C.newWin CD.scrH CD.scrW 0 0)- insWin TutorialWin =<< liftIO (C.newWin 3 3 0 50)+ sequence_ [ insWin win =<< liftIO (C.newWin h w y x)+ | (win, WinDim x y w h) <- M.assocs geometry ] pure True endUI = liftIO CH.end draw game = unlessSmall $ do@@ -58,26 +53,26 @@ st = G.playState game stateWins = case st of G.RoundEnded -> [MainWin]- G.Tutorialising b | isJust (CD.tutBox b) -> gameWindows <> [TutorialWin]+ G.Tutorialising b | isJust (TD.tutBox b) -> gameWindows <> [TutorialWin] _ -> gameWindows gameWindows = allWindows \\ [MainWin,TutorialWin] drawState = case st of- G.RoundEnded -> CD.drawMainScreen game+ G.RoundEnded -> TD.drawMainScreen game _ -> do let bd = G.board game- forM_ (reverse $ G.transitions game) CD.drawTrans- CD.drawBoard bd- CD.drawInv (G.selectedSlot game) (G.preserveSlots game) (G.canGrab game) (G.inventory game) (G.powerOn game)- CD.drawEquip $ G.equipment game- CD.drawStatus game- CD.drawLevelInfo bd- CD.drawMessage game+ forM_ (reverse $ G.transitions game) TD.drawTrans+ 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+ TD.drawStatus game+ TD.drawLevelInfo bd+ TD.drawMessage game case st of- G.Tutorialising b -> CD.highlightTut b+ G.Tutorialising b -> TD.highlightTut b _ -> pure () unlessSmall m = do (h,w) <- liftIO C.scrSize- if h < CD.scrH || w < CD.scrW then+ if h < scrH || w < scrW then let s = "Terminal too small!" in if w < length s || h < 1 then pure () else do
+ Geometry.hs view
@@ -0,0 +1,38 @@+module Geometry where++import qualified Data.Map.Strict as M++import Window++import qualified Board as B+import qualified Inventory as I++-- Terminal size+scrW,scrH :: Int+scrW = 60+scrH = 20++data WinDim = WinDim+ { windimx :: Int+ , windimy :: Int+ , windimw :: Int+ , windimh :: Int+ }++geometry :: M.Map Window WinDim+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))+ , (LevelInfoWin, WinDim 1 (1 + afterBoard) scrW 3)+ , (MessageWin, WinDim 0 (1 + 3 + 1 + afterBoard) scrW 1)+ , (MainWin, WinDim 0 0 scrW scrH)+ , (TutorialWin, WinDim 50 0 3 3) -- Only used by CursesUI, which moves it around+ ]+ where+ -- |Can draw on board at CPos x y for x < bdcW and y < bdcH+ bdcW,bdcH :: Int+ bdcW = B.w * 3 + 1+ bdcH = B.h * 2 + 1+ afterBoard = 3 + max bdcH (3 + length I.slots)
Main.hs view
@@ -20,18 +20,30 @@ import System.Exit (exitSuccess) import System.FilePath ((</>)) -import CursesUIMInstance () import GameName import KeyBindings (dvorakViBindings) import Serialise () import qualified Command as Cmd-import qualified CursesUI as CU import qualified Game as G import qualified Highscore as HS import qualified HighscoreFile as HSF import qualified UIMonad as UIM +#ifdef CURSES+import qualified CursesUI as CU+import CursesUIMInstance ()+#endif++#ifdef BEAR+import qualified BearUI as BU+import BearUIMInstance ()+#ifdef CURSES+#define BOTH+import Control.Monad (unless)+#endif+#endif+ version :: String version = CURRENT_PACKAGE_VERSION @@ -42,6 +54,9 @@ | Dvorak | Help | Version+#ifdef BOTH+ | Curses+#endif deriving (Eq, Ord, Show) options :: [OptDescr Opt]@@ -52,6 +67,9 @@ , Option ['d'] ["dvorak"] (NoArg Dvorak) "Use dvorak roguelike keys (htns)" , Option ['h'] ["help"] (NoArg Help) "Show usage information" , Option ['v'] ["version"] (NoArg Version) "Show version information"+#ifdef BOTH+ , Option ['c'] ["curses"] (NoArg Curses) "Run in textmode"+#endif ] usage :: String@@ -78,28 +96,45 @@ let ascii = AsciiOnly `elem` opts let dvorak = Dvorak `elem` opts let username = headMay [ name | Username name <- opts ]++ let ui :: UIM.UIMonad m => m ()+ ui = G.runT $ do+ lift $ UIM.setAsciiOnly ascii+ when dvorak . lift $ sequence_ [ UIM.setUIBinding ch cmd | (ch,cmd) <- dvorakViBindings ]+ liftIO (tryAny $ readFileDeserialise statePath) >>= \case+ Right game -> put game+ Left _ -> G.initGame+ let mainLoop :: UIM.UIMonad uiM => G.T uiM ()+ mainLoop = do+ liftIO . writeFileSerialise statePath =<< get+ lift . UIM.draw =<< get+ G.clearTrans+ playSt <- gets G.playState+ let after = do+ playSt' <- gets G.playState+ when (playSt == G.Playing && playSt' `elem` [G.Dead, G.Won]) $+ liftIO . HSF.add =<< gets (G.highscore username)+ mainLoop+ runExceptT (mapM_ processCommand =<< (lift . lift) UIM.getInput) >>=+ either pure (const after)+ mainLoop++#ifdef BEAR+ let doBUI :: BU.UIM () -> IO ()+ doBUI m = void (UIM.doUI m) `catch` (\QuitException -> exitSuccess)++#ifdef CURSES+ unless (Curses `elem` opts) $ doBUI ui+#else+ doBUI ui+#endif+#endif++#ifdef CURSES let doCUI :: CU.UIM () -> IO () doCUI m = void (UIM.doUI m) `catch` (\QuitException -> exitSuccess)- doCUI . G.runT $ do- lift $ UIM.setAsciiOnly ascii- when dvorak . lift $ sequence_ [ UIM.setUIBinding ch cmd | (ch,cmd) <- dvorakViBindings ]- liftIO (tryAny $ readFileDeserialise statePath) >>= \case- Right game -> put game- Left _ -> G.initGame- let mainLoop :: UIM.UIMonad uiM => G.T uiM ()- mainLoop = do- liftIO . writeFileSerialise statePath =<< get- lift . UIM.draw =<< get- G.clearTrans- playSt <- gets G.playState- let after = do- playSt' <- gets G.playState- when (playSt == G.Playing && playSt' `elem` [G.Dead, G.Won]) $- liftIO . HSF.add =<< gets (G.highscore username)- mainLoop- runExceptT (mapM_ processCommand =<< (lift . lift) UIM.getInput) >>=- either pure (const after)- mainLoop+ doCUI ui+#endif data QuitException = QuitException deriving Show
README.md view
@@ -12,3 +12,7 @@ Run with `cabal run`. Install with `cabal install`.++### Bearlibterminal+In case you don't have or like ncurses, the game also supports this alternative terminal library which runs in graphical mode (via OpenGL).+Install [bearlibterminal](http://foo.wyrd.name/en:bearlibterminal), then run with `cabal run -fbear`.
+ TermDraw.hs view
@@ -0,0 +1,575 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TupleSections #-}++module TermDraw where++import Control.Concurrent (threadDelay)+import Control.Monad (forM, forM_, mplus, unless, void)+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 Safe (atMay)++#if !MIN_VERSION_base(4,20,0)+-- foldl' started being exported from prelude in base-4.20.0+import Data.Foldable (foldl')+#endif++import qualified Data.Map.Strict as M+import qualified Data.Set as S++import Creature+import CStyle+import Equipment+import Exit+import Geometry+import Group+import Item+import Wall+import Window++import qualified Board as B+import qualified BoardConf as BC+import qualified CPos as CP+import qualified Game as G+import qualified Highscore as HS+import qualified HighscoreFile as HSF+import qualified Inventory as I+import qualified Pos as P+import qualified Power as Pow+import qualified RollFrom as RF+import qualified TermM as TM+import qualified Tutorial as T++invItemGlyph :: InvItem -> Glyph+invItemGlyph e = Glyph c $ CStyle cyan True where+ c = case e of+ Orb -> 'o'+ Cloak -> '['+ Umbrella -> '/'+ Balloon _ -> '&'+ Flash -> '='+ Camera _ -> ')'+ Tent -> 'A'+ Spraypaint _ -> ':'++drawStyledStrs :: TM.TermM m => Window -> CP.CPos -> [(String, CStyle)] -> m ()+drawStyledStrs win (CP.CPos x0 y) = void . (`runStateT` x0) . mapM draw where+ draw (s,style) = do+ x <- get+ lift $ TM.drawStr win style (CP.CPos x y) s+ put $ x + length s++twoCharNum :: Int -> String+twoCharNum n | 0 <= n && n < 10 = ' ' : show n+ | otherwise = take 2 $ show n++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+ let win = StatusWin+ unless (M.null statuses) $ drawStyledStrs win (CP.CPos 0 0) statusStrs+ drawStyledStrs win (CP.CPos 0 1) numStrs+ where+ -- XXX: keep in sync with magic numbers in highlightTut+ numStrs =+ [ ("Life: ", style0)+ , (twoCharNum life, lifeStyle)+ , ("/", 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)+ , ("%", 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 ]+ statStyle (B.Dazzled,_) = CStyle cyan True+ statStyle (B.Ghost,_) = style0+ 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++exitChar :: P.Dir -> Char+exitChar = \case+ P.DUp -> '^'+ P.DDown -> 'v'+ P.DRight -> '>'+ P.DLeft -> '<'++drawBoard :: TM.TermM m => B.Board -> m ()+drawBoard = drawAlertedBoard . baseAlerted++data AlertedBoard = AlertedBoard+ { base :: B.Board+ , creatureMoves :: M.Map P.WPos Creature+ , itemMoves :: M.Map P.WPos Item+ , itemUses :: M.Map P.WPos Item+ , highlightPs :: S.Set P.Pos+ , highlightWPs :: S.Set P.WPos+ }+baseAlerted :: B.Board -> AlertedBoard+baseAlerted bd = AlertedBoard bd M.empty M.empty M.empty S.empty S.empty++drawTrans :: TM.TermM m => B.Transition -> m ()+drawTrans (B.Transition bd0 alerts) =+ let alerted = foldl' applyAlert (baseAlerted bd0) alerts+ in do+ drawAlertedBoard alerted+ TM.wRefresh BoardWin+ TM.wErase BoardWin+ liftIO (threadDelay 50000)+ where+ applyAlert alerted (B.AlertMoveCreature c p d) =+ alerted { creatureMoves = M.insert (P.wposInDir p d) c $ creatureMoves alerted+ , base = B.modCreatures (M.delete p) $ 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+ }+ applyAlert alerted (B.AlertUseItem i p d) =+ alerted { itemUses = M.insert (P.wposInDir p d) i $ itemUses alerted+ , base = B.modItems (M.delete p) $ base alerted+ }+ applyAlert alerted (B.AlertHighlight ps wps) =+ alerted { highlightPs = ps `S.union` highlightPs alerted+ , highlightWPs = wps `S.union` highlightWPs alerted+ }++char,bold,dim :: Char -> Glyph+char c = Glyph c style0+bold c = Glyph c styleBold+dim c = Glyph c $ CStyle (onBlue white) False++levelStyle :: Int -> CStyle+levelStyle 1 = CStyle green False+levelStyle 2 = CStyle white True+levelStyle 3 = CStyle yellow True+levelStyle _ = style0++showLevel :: Int -> String+showLevel l | l > 0 = (['A'..] !! (l-1)):""+showLevel _ = "-"++scoreStyle, junkStyle :: CStyle+scoreStyle = CStyle yellow False+junkStyle = CStyle blue True++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 (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 CameraBoxed = Glyph ')' $ CStyle cyan False+itemGlyph (RollingOrb _ _) = Glyph 'o' $ CStyle cyan False+itemGlyph (ItemInvItem e) = invItemGlyph e++wallGlyphVert :: Wall -> Glyph+wallGlyphVert = \case+ BasicWall -> bold wallchar+ Pillar -> char '|'+ Hedge -> Glyph wallchar $ CStyle green True+ ThickHedge -> Glyph '║' $ CStyle green False+ Window -> Glyph wallchar $ CStyle cyan False+ BrokenWindow -> Glyph ';' $ CStyle cyan False+ (CloakWall _ _) -> Glyph wallchar $ CStyle cyan True+ (UmbrellaWall d) -> Glyph (if d == P.DRight then '>' else '<') $ CStyle magenta True+ TentWall -> Glyph wallchar $ CStyle red True+ where wallchar = '│'++wallGlyphHoriz :: Wall -> (Glyph,Glyph)+wallGlyphHoriz = \case+ Pillar -> (char '-', char '-')+ (UmbrellaWall P.DUp) -> (umb '/', umb '\\')+ (UmbrellaWall _) -> (umb '\\', umb '/')+ BasicWall -> doublet $ bold wallchar+ Hedge -> doublet . Glyph wallchar $ CStyle green True+ ThickHedge -> doublet . Glyph '═' $ CStyle green False+ Window -> doublet . Glyph wallchar $ CStyle cyan False+ BrokenWindow -> (Glyph '.' $ CStyle cyan False , Glyph ',' $ CStyle cyan False)+ (CloakWall _ _) -> doublet . Glyph wallchar $ CStyle cyan True+ TentWall -> doublet . Glyph wallchar $ CStyle red True+ where+ wallchar = '─'+ umb c = Glyph c $ CStyle magenta True+ doublet gl = (gl,gl)++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 '.'+ 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 '.'+ SeenBoundary -> doublet $ Glyph '─' st+ where doublet gl = (gl,gl)++-- positions in board window+posCPosL, posCPosR, posIntCPos :: P.Pos -> CP.CPos+posCPosL (P.Pos x y) = CP.CPos (3*(x+1) - 2) $ 2*(B.h - y) - 1+posCPosR = (CP.CPos 1 0 <>) . posCPosL+posIntCPos p = posCPosL p <> CP.CPos 2 (-1)+wposCPos, wposCPosR :: P.WPos -> CP.CPos+wposCPos (P.WPos p up) = posCPosL p <> if up then CP.CPos 0 (-1) else CP.CPos 2 0+wposCPosR = (CP.CPos 1 0 <>) . wposCPos++drawAlertedBoard :: TM.TermM m => AlertedBoard -> m ()+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+ 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+ filterV = M.filterWithKey $ const . not . P.up+ filterH = M.filterWithKey $ const . P.up+ filterSV = S.filter $ not . P.up+ filterSH = S.filter P.up+ 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+ bdWallsV = glyphsV (const wallGlyphVert) $ B.walls bd+ bdWallsH = glyphsH (const wallGlyphHoriz) $ B.walls bd+ 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.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' c = creatureGlyph c+ obscured = M.fromSet (\p -> (Just . dim $ expectChar p,) . Just . powerBG p . dim $ obsChar p) $ B.poss S.\\ B.visible bd where+ expectChar p+ | B.expectant bd+ , Just (Just c) <- B.expected bd M.!? p = glyphChar $ creatureGlyph' c+ | otherwise = ' '+ obsChar p+ | p `S.member` B.unrevealed bd = expectedTreasureChar p+ | otherwise = ' '+ expectedTreasureChar = glyphChar . itemGlyph . B.treasureAt bd+ wObscuredV = M.fromSet (const $ dim ' ') . filterSV $ obscuredWPoss+ wObscuredH = M.fromSet (const . biGlyph $ dim ' ') . filterSH $ obscuredWPoss+ obscuredWPoss = B.invisibleWPoss (B.tagged bd) (B.visible bd)+ mvingV = M.map creatureGlyph' (filterV cmvs) `M.union` M.map itemGlyph (filterV $ imvs `M.union` iuses)+ mvingH = M.map ((,Nothing) . Just . creatureGlyph') (filterH cmvs)+ `M.union` M.map ((Nothing,) . Just . itemGlyph) (filterH imvs)+ `M.union` M.map ((,Nothing) . Just . itemGlyph) (filterH iuses)+ highlightCells = M.fromSet (const . biGlyph $ bold '#') hps+ highlightV = M.fromSet (const $ bold '#') $ filterSV hwps+ 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) ]+ 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++ 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)+ horizWCPosMap :: M.Map P.WPos (Maybe Glyph, Maybe Glyph) -> M.Map CP.CPos Glyph+ horizWCPosMap m = M.mapMaybe fst (M.mapKeys wposCPos m) `M.union` M.mapMaybe snd (M.mapKeys wposCPosR m)++ glyphs :: M.Map CP.CPos Glyph+ glyphs = M.unions+ [ horizCPosMap cells+ , M.mapKeys wposCPos wallsV+ , horizWCPosMap wallsH+ , M.mapKeys posIntCPos intersections+ ]+ in do+ sequence_ $ M.mapWithKey (TM.drawGlyph BoardWin) glyphs++drawInv :: TM.TermM m => Maybe I.Slot -> Int -> Bool -> I.Inventory -> Maybe Pow.Power -> m ()+drawInv sel preserve highlightEmpty (I.Inventory inv) pow = do+ let win = InvWin+ let str x y st = TM.drawStr win st (CP.CPos x y)+ str 0 0 styleBold "Inventory:"+ sequence_ $+ [ do+ str 0 slot style (show slot)+ case me of+ Nothing -> pure ()+ 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+ | 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+ ]++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++drawEquip :: TM.TermM m => S.Set Equipment -> m ()+drawEquip es | S.null es = pure ()+drawEquip es = do+ let win = EquipWin+ let str x y st = TM.drawStr win st (CP.CPos x y)+ str 0 0 styleBold "Equipment:"+ forM_ (zip [1..] (S.toList es)) $ \(y,e) ->+ str 0 y (equipStyle e) $ show e++drawMessage :: TM.TermM m => G.Game -> m ()+drawMessage game = do+ let win = MessageWin+ (text,style) = case G.playState game of+ G.Dead -> ("You died with " <> show (G.score game) <>+ " points on level " <> show (G.round game) <>+ ":" <> showLevel (G.level game) <> ". [Space]", styleBold)+ G.Won -> ("Congratulations, you win! [Space]", styleBold)+ G.Tutorialising b -> (T.text b <> " [Spc/T]", CStyle magenta True)+ _ -> ("", style0)+ TM.drawStr win style (CP.CPos 0 0) text++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+ 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 ']' ]+ bc = B.conf bd+ diffs = B.diffs bd+ drawDiffsLine y = TM.drawStr win style0 (CP.CPos 0 y) introStr >> sequence_+ [ do+ draw b . char' $ exitChar dir+ draw (b+1) (char ':')+ forM (zip [0..] rdfs) (\(x,rdf) -> draw (b+3+x) $ rdfGlyph rdf)+ | (n,dir) <- zip [0..] P.dirs+ , dir `elem` possibleExitDirs+ , let b = length introStr + 8*n+ , let char'+ | dir `elem` exitDirs = bold+ | dir `elem` keyExitDirs = \c -> Glyph c $ equipStyle Key+ | otherwise = char+ , Just rdfs <- [diffs M.!? dir]+ ]+ where+ introStr = "On exit: "+ 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+ possibleExitDirs = exitDirs <> keyExitDirs <> exitsWith UnseenBoundary++data HSInfo+ = HSRank Int+ | HSAlive+ | HSDead+ | HSWon++drawMainScreen :: TM.TermM m => G.Game -> m ()+drawMainScreen game = do+ let win = MainWin+ curHs = twiddle $ G.highscore Nothing game where+ twiddle hs = hs { HS.maxLevel = 0, HS.maxRound = HS.maxRound hs + 1 }+ centre style y s+ | y >= scrH = pure ()+ | otherwise = TM.drawStr win style (CP.CPos ((scrW - length s) `div` 2) y) s+ drawTitle = sequence_ [ drawStyledStrs win (CP.CPos titleX y) s+ | (y,s) <-+ [ (0, [ ("·──·──·──·", bdSt), (" ", bgSt) ])+ , (1, [ ("│", bdSt), (" Fe@r of", styleBold)+ , ("│", bdSt), ("View ", bgSt) ])+ , (2, [ ("·──· ·──·", bdSt), (" ", bgSt) ])+ ]+ ] where+ titleX = (scrW - length "| Fe@r of|View") `div` 2+ bdSt = CStyle yellow True+ bgSt = CStyle (onBlue white) True+ wonStyle = CStyle magenta True++ ascii <- TM.asciiOnly++ let drawHS :: TM.TermM m => Bool -> Int -> HSInfo -> HS.Highscore -> m ()+ drawHS showName y info hs =+ drawStyledStrs win (CP.CPos (scoreX showName) y) $+ (case info of+ HSRank rank -> [(twoCharNum rank, styleBold)]+ HSAlive -> [(" @", styleBold)]+ HSDead -> [(" ",style0), ("@", CStyle (onRed white) True)]+ HSWon -> [(" ",style0), ("@", wonStyle)]+ ) <>+ [ (" ", style0)+ ] <>+ [ (take 8 (fromMaybe "[anon]" (HS.name hs) <> repeat ' ') <> " ", CStyle cyan True)+ | showName+ ] <>+ [ (twoCharNum (HS.score hs) <> "~",+ if HS.score hs == G.maxScore then wonStyle else scoreStyle)+ , (" ", style0)+ , (twoCharNum (HS.maxRound hs) <> ":", style0)+ , let lev = HS.maxLevel hs in (showLevel lev, levelStyle lev)+ ] <>+ [ (" ", 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"]+ <> [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" ]+ aKeyL = maximum $ length <$> additionalKeys++ let keysLine y = centre style0 y "Keys: cursors / WASD / HJKL; 0-9"++ drawTitle+ if HS.maxRound curHs > 1+ then do+ centre styleBold 3 "Game in progress:"+ drawHS False 4 HSAlive curHs+ centre styleBold 6 "Press Space to continue"+ else case G.prevHS game of+ Just prev -> do+ centre style0 3 "Last game:"+ let info | HS.score prev >= G.maxScore = HSWon+ | otherwise = HSDead+ 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+ unless (null hss) $ do+ let someNamed = any (isJust . HS.name) hss+ drawStyledStrs win (CP.CPos (scoreX someNamed - 1) 9) $+ [ ("Rank ", styleBold) ] <>+ [ (" Name ", CStyle cyan True) | someNamed ] <>+ [ ("Score ", scoreStyle)+ , ("Level ", style0)+ , ("Equip", style0) ]+ sequence_ [ drawHS someNamed (10+i) (HSRank $ 1+i) hs | (i,hs) <- zip [0..] hss ]++ sequence_ [ TM.drawStr win+ (CStyle (onBlue white) $ n == 0)+ (CP.CPos (scrW - 2 - aKeyL) $ 10 + n) . take aKeyL $ s <> repeat ' '+ | (s,n) <- zip additionalKeys [0..]+ ]++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.SeeMonster p c) = Just (boardOffset <> posCPosL p, [creatureGlyph c])+ tutBox' (T.SeeExit wp) = Just (boardOffset <> wposCPos wp, [bold . exitChar $ 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.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' _ = Nothing+ winOffset win = CP.CPos x y where WinDim x y _ _ = geometry M.! win+ boardOffset = winOffset BoardWin+ invOffset = winOffset InvWin+ statusOffset = winOffset StatusWin+ levelInfoOffset = winOffset LevelInfoWin++highlightTut :: TM.TermM m => T.Beat -> m ()+highlightTut = maybe (pure ()) (uncurry TM.drawHighlightBoxChars) . tutBox
+ TermM.hs view
@@ -0,0 +1,15 @@+module TermM where++import Control.Monad.IO.Class (MonadIO)++import CStyle+import Window++import qualified CPos as CP++class MonadIO m => TermM m where+ drawStr :: Window -> CStyle -> CP.CPos -> String -> m ()+ drawGlyph :: Window -> CP.CPos -> Glyph -> m ()+ wErase, wRefresh :: Window -> m ()+ drawHighlightBoxChars :: CP.CPos -> [Glyph] -> m ()+ asciiOnly :: m Bool
+ VeraMoBd.ttf view
binary file changed (absent → 49052 bytes)
+ Window.hs view
@@ -0,0 +1,14 @@+module Window where++data Window+ = MainWin+ | StatusWin+ | BoardWin+ | InvWin+ | EquipWin+ | LevelInfoWin+ | MessageWin+ | TutorialWin+ deriving (Eq,Ord,Enum,Bounded)+allWindows :: [Window]+allWindows = [minBound..maxBound]
fearOfView.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.2 name: fearOfView-version: 0.1.0.3+version: 0.1.1.0 license: AGPL-3.0-or-later license-file: COPYING maintainer: mbays@sdf.org@@ -9,15 +9,26 @@ synopsis: A terminal broughlike game about manipulating vision description: A constrained roguelike ("broughlike") game played on a 5x5 grid of cells- which are regenerated when out of view. Designed for colour terminals,- using the ncurses library.+ 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 + bearlibterminal. category: Game extra-doc-files: CHANGELOG.md README.md fov-shot.png+data-files: VeraMoBd.ttf source-repository head type: git location: https://thegonz.net/~fov/fearOfView.git +flag bear+ description: Build bearlibterminal UI+ -- This library doesn't use pkgconfig, so if the flag defaulted to True,+ -- cabal would try but fail to link on systems without the library.+ default: False++flag curses+ description: Build curses UI+ flag debug description: Enable debug keys default: False@@ -25,7 +36,6 @@ executable fearOfView main-is: Main.hs- pkgconfig-depends: ncursesw other-modules: AStar Board@@ -34,14 +44,12 @@ Creature CPos CStyle- CursesDraw- CursesUI- CursesUIMInstance Equipment Exit Inventory Game GameName+ Geometry Group Highscore HighscoreFile@@ -53,8 +61,11 @@ RollFrom UIMonad Serialise+ TermDraw+ TermM Tutorial Wall+ Window default-language: Haskell2010 ghc-options: -Wall@@ -66,7 +77,6 @@ directory >=1.2.3.0 && <1.4, filepath >=1.0 && <2.1, safe-exceptions >=0.1 && <0.2,- hscurses >=1.4 && <1.6, MonadRandom >=0.6 && <0.7, splitmix >=0.1 && <0.2, random >=1.3 && <1.4,@@ -79,3 +89,27 @@ if flag(debug) cpp-options: -DDEBUG++ if flag(curses)+ cpp-options: -DCURSES+ pkgconfig-depends: ncursesw+ other-modules:+ CursesUI+ CursesUIMInstance+ build-depends:+ hscurses >=1.4 && <1.6,++ if flag(bear)+ cpp-options: -DBEAR+ other-modules:+ BearUI+ BearUIMInstance+ build-depends:+ bearlibterminal >=0.1 && <0.2+ extra-libraries:+ BearLibTerminal++ if (!flag(curses) && !flag(bear))+ -- Require at least one of curses or bear+ buildable: False+ build-depends: base <0