diff --git a/BearUI.hs b/BearUI.hs new file mode 100644 --- /dev/null +++ b/BearUI.hs @@ -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 diff --git a/BearUIMInstance.hs b/BearUIMInstance.hs new file mode 100644 --- /dev/null +++ b/BearUIMInstance.hs @@ -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 [] diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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) diff --git a/CStyle.hs b/CStyle.hs --- a/CStyle.hs +++ b/CStyle.hs @@ -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) diff --git a/CursesDraw.hs b/CursesDraw.hs deleted file mode 100644 --- a/CursesDraw.hs +++ /dev/null @@ -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 diff --git a/CursesUI.hs b/CursesUI.hs --- a/CursesUI.hs +++ b/CursesUI.hs @@ -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 + diff --git a/CursesUIMInstance.hs b/CursesUIMInstance.hs --- a/CursesUIMInstance.hs +++ b/CursesUIMInstance.hs @@ -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 diff --git a/Geometry.hs b/Geometry.hs new file mode 100644 --- /dev/null +++ b/Geometry.hs @@ -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) diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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`. diff --git a/TermDraw.hs b/TermDraw.hs new file mode 100644 --- /dev/null +++ b/TermDraw.hs @@ -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 diff --git a/TermM.hs b/TermM.hs new file mode 100644 --- /dev/null +++ b/TermM.hs @@ -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 diff --git a/VeraMoBd.ttf b/VeraMoBd.ttf new file mode 100644 Binary files /dev/null and b/VeraMoBd.ttf differ diff --git a/Window.hs b/Window.hs new file mode 100644 --- /dev/null +++ b/Window.hs @@ -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] diff --git a/fearOfView.cabal b/fearOfView.cabal --- a/fearOfView.cabal +++ b/fearOfView.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: fearOfView -version: 0.1.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