Permalink
Browse files

half of the display frontend no longer accessible outside

  • Loading branch information...
1 parent 18003aa commit 61fa35549025894b00c59807cc6bf9308b0774eb @Mikolaj Mikolaj committed Mar 24, 2011
Showing with 304 additions and 298 deletions.
  1. +1 −1 LambdaHack.cabal
  2. +1 −1 src/Action.hs
  3. +1 −1 src/Actions.hs
  4. +4 −4 src/Attr.hs
  5. +4 −4 src/Config.hs
  6. +244 −4 src/Display.hs
  7. +2 −2 src/Display/Curses.hs
  8. +4 −4 src/Display/Gtk.hs
  9. +13 −11 src/Display/Vty.hs
  10. +0 −235 src/Display2.hs
  11. +3 −4 src/Keybindings.hs
  12. +26 −26 src/LambdaHack.hs
  13. +1 −1 src/Turn.hs
View
@@ -25,7 +25,7 @@ executable LambdaHack
main-is: LambdaHack.hs
hs-source-dirs:src
other-modules: Attr, Action, Actions, Command, Config, ConfigDefault,
- Display, Display2, Dungeon, DungeonState, File,
+ Display, Dungeon, DungeonState, File,
FOV, FOV.Common, FOV.Digital, FOV.Permissive, FOV.Shadow,
Frequency, Geometry, GeometryRnd, Grammar,
HeroState, HighScores, Item, ItemState,
View
@@ -7,7 +7,7 @@ import Data.List as L
-- import System.IO (hPutStrLn, stderr) -- just for debugging
import Perception
-import Display2 hiding (display)
+import Display hiding (display)
import Message
import State
import Level
View
@@ -11,7 +11,7 @@ import Data.Set as S
import System.Time
import Action
-import Display2 hiding (display)
+import Display hiding (display)
import Dungeon
import Geometry
import Grammar
View
@@ -1,6 +1,6 @@
module Attr where
-import qualified Data.Binary
+import qualified Data.Binary as Binary
data Color =
Black
@@ -21,10 +21,10 @@ data Color =
| BrWhite
deriving (Show, Eq, Ord, Enum, Bounded)
-instance Data.Binary.Binary Color where
- put c = Data.Binary.putWord8 $ toEnum $ fromEnum c
+instance Binary.Binary Color where
+ put c = Binary.putWord8 $ toEnum $ fromEnum c
get = do
- c <- Data.Binary.getWord8
+ c <- Binary.getWord8
return $ toEnum $ fromEnum c
defBG, defFG :: Color
View
@@ -9,16 +9,16 @@ import Control.Monad.Error
import qualified Data.ConfigFile as CF
import Data.Either.Utils
import Data.Maybe
-import qualified Data.Binary as B
+import qualified Data.Binary as Binary
import qualified ConfigDefault
newtype CP = CP CF.ConfigParser
-instance B.Binary CP where
- put (CP config) = B.put $ CF.to_string config
+instance Binary.Binary CP where
+ put (CP config) = Binary.put $ CF.to_string config
get = do
- string <- B.get
+ string <- Binary.get
-- use config in case savegame is from older version and lacks some options
let c = CF.readstring defCF string
return $ toCP $ forceEither c
View
@@ -1,14 +1,254 @@
{-# LANGUAGE CPP #-}
-module Display (module D) where
+module Display where
-- wrapper for selected Display frontend
#ifdef CURSES
-import Display.Curses as D
+import qualified Display.Curses as D
#elif GTK
-import Display.Gtk as D
+import qualified Display.Gtk as D
#else
-import Display.Vty as D
+import qualified Display.Vty as D
#endif
+-- Display routines that are independent of the selected display frontend.
+
+import qualified Data.Char as Char
+import Data.Set as S
+import Data.List as L
+import Data.Map as M
+import qualified Data.IntMap as IM
+import Control.Monad.State hiding (State) -- for MonadIO, seems to be portable between mtl-1 and 2
+import Data.Maybe
+
+import Message
+import qualified Attr
+import State
+import Geometry
+import Level
+import LevelState
+import Dungeon
+import Perception
+import Movable
+import MovableState
+import Monster
+import Item
+import Keys as K
+import qualified Terrain
+
+-- Re-exported from the display frontend.
+type Session = D.Session
+display = D.display
+startup = D.startup
+shutdown = D.shutdown
+displayId = D.displayId
+
+-- | Next event translated to a canonical form
+nextCommand :: MonadIO m => Session -> m Key
+nextCommand session =
+ do
+ e <- liftIO $ D.nextEvent session
+ return (canonicalKey e)
+
+-- | maps a key to the canonical key for the command it denotes
+canonicalKey :: Key -> Key
+canonicalKey e =
+ case e of
+ K.KP '8' -> K.Char 'K'
+ K.KP '2' -> K.Char 'J'
+ K.KP '4' -> K.Char 'H'
+ K.KP '6' -> K.Char 'L'
+ K.KP '7' -> K.Char 'Y'
+ K.KP '9' -> K.Char 'U'
+ K.KP '1' -> K.Char 'B'
+ K.KP '3' -> K.Char 'N'
+ K.KP '5' -> K.Char '.'
+ K.Up -> K.Char 'k'
+ K.Down -> K.Char 'j'
+ K.Left -> K.Char 'h'
+ K.Right -> K.Char 'l'
+ K.Home -> K.Char 'y'
+ K.PgUp -> K.Char 'u'
+ K.End -> K.Char 'b'
+ K.PgDn -> K.Char 'n'
+ K.Begin -> K.Char '.'
+ k -> k
+
+-- | Displays a message on a blank screen. Waits for confirmation.
+displayBlankConfirm :: Session -> String -> IO Bool
+displayBlankConfirm session txt =
+ let x = txt ++ more
+ doBlank = const (D.defaultAttr, ' ')
+ in do
+ display ((0, 0), normalLevelSize) session doBlank x ""
+ getConfirm session
+
+-- | Waits for a space or return or '?' or '*'. The last two to let keys that
+-- request (more) information toggle display of the obtained information off.
+getConfirm :: MonadIO m => Session -> m Bool
+getConfirm session =
+ getOptionalConfirm return (const $ getConfirm session) session
+
+getOptionalConfirm :: MonadIO m =>
+ (Bool -> m a) -> (Key -> m a) -> Session -> m a
+getOptionalConfirm h k session =
+ do
+ e <- liftIO $ nextCommand session
+ case e of
+ K.Char ' ' -> h True
+ K.Char '?' -> h True
+ K.Char '*' -> h True
+ K.Return -> h True
+ K.Esc -> h False
+ _ -> k e
+
+-- | A yes-no confirmation.
+getYesNo :: MonadIO m => Session -> m Bool
+getYesNo session =
+ do
+ e <- liftIO $ nextCommand session
+ case e of
+ K.Char 'y' -> return True
+ K.Char 'n' -> return False
+ K.Esc -> return False
+ _ -> getYesNo session
+
+-- | Configurable event handler for the direction keys. Is used to
+-- handle player moves, but can also be used for directed commands
+-- such as open/close.
+handleDirection :: Key -> (Dir -> a) -> a -> a
+handleDirection e h k =
+ case e of
+ K.Char 'k' -> h up
+ K.Char 'j' -> h down
+ K.Char 'h' -> h left
+ K.Char 'l' -> h right
+ K.Char 'y' -> h upleft
+ K.Char 'u' -> h upright
+ K.Char 'b' -> h downleft
+ K.Char 'n' -> h downright
+ _ -> k
+
+-- | Configurable event handler for the upper direction keys. Is used to
+-- handle player moves, but can also be used for directed commands
+-- such as open/close.
+handleUDirection :: Key -> (Dir -> a) -> a -> a
+handleUDirection e h k =
+ case e of
+ K.Char 'K' -> h up
+ K.Char 'J' -> h down
+ K.Char 'H' -> h left
+ K.Char 'L' -> h right
+ K.Char 'Y' -> h upleft
+ K.Char 'U' -> h upright
+ K.Char 'B' -> h downleft
+ K.Char 'N' -> h downright
+ _ -> k
+
+splitOverlay :: Int -> String -> [[String]]
+splitOverlay s xs = splitOverlay' (lines xs)
+ where
+ splitOverlay' ls
+ | length ls <= s = [ls] -- everything fits on one screen
+ | otherwise = let (pre,post) = splitAt (s - 1) ls
+ in (pre ++ [more]) : splitOverlay' post
+
+-- | Returns a function that looks up the characters in the
+-- string by location. Takes the height of the display plus
+-- the string. Returns also the number of screens required
+-- to display all of the string.
+stringByLocation :: Y -> String -> (Int, Loc -> Maybe Char)
+stringByLocation sy xs =
+ let
+ ls = splitOverlay sy xs
+ m = M.fromList (zip [0..] (L.map (M.fromList . zip [0..]) (concat ls)))
+ k = length ls
+ in
+ (k, \ (y,x) -> M.lookup y m >>= \ n -> M.lookup x n)
+
+displayLevel ::
+ Session -> Perceptions -> State -> Message -> Maybe String -> IO Bool
+displayLevel
+ session per
+ (state@(State { scursor = cursor,
+ stime = time,
+ sassocs = assocs,
+ slevel = Level ln _ (sy, sx) _ smap lmap _ }))
+ msg moverlay =
+ let Movable { mtype = MovableType { nhpMax = xhp },
+ mhp = php, mloc = ploc, mitems = pitems } = getPlayerBody state
+ reachable = ptreachable per
+ visible = ptvisible per
+ overlay = fromMaybe "" moverlay
+ (n, over) = stringByLocation (sy+1) overlay -- n overlay screens needed
+ sSml = ssensory state == Smell
+ sVis = case ssensory state of Vision _ -> True; _ -> False
+ sOmn = sdisplay state == Omniscient
+ sTer = case sdisplay state of Terrain n -> n; _ -> 0
+ lAt = if sOmn || sTer > 0 then at else rememberAt
+ sVisBG = if sVis
+ then \ vis rea -> if vis
+ then Attr.Blue
+ else if rea
+ then Attr.Magenta
+ else Attr.defBG
+ else \ vis rea -> Attr.defBG
+ gItem = findItem (\ i -> iletter i == Just '$') pitems
+ gold = maybe 0 (icount . fst) gItem
+ hs = levelHeroList state
+ ms = levelMonsterList state
+ dis n loc =
+ let tile = lmap `lAt` loc
+ sml = ((smap ! loc) - time) `div` 100
+ viewMovable loc (Movable { mtype = mt })
+ | loc == ploc && ln == creturnLn cursor =
+ (nsymbol mt, Attr.defBG) -- highlight player
+ | otherwise = (nsymbol mt, ncolor mt)
+ viewSmell :: Int -> Char
+ viewSmell n
+ | n > 9 = '*'
+ | n < 0 = '-'
+ | otherwise = Char.intToDigit n
+ (char, fg) =
+ case L.find (\ m -> loc == mloc m) (hs ++ ms) of
+ _ | sTer > 0 -> Terrain.viewTerrain sTer False (tterrain tile)
+ Just m | sOmn || vis -> viewMovable loc m
+ _ | sSml && sml >= 0 -> (viewSmell sml, Attr.Green)
+ | otherwise -> viewTile vis tile assocs
+ vis = S.member loc visible
+ rea = S.member loc reachable
+ bg = if ctargeting cursor && loc == clocation cursor
+ then Attr.defFG -- highlight targeting cursor
+ else sVisBG vis rea -- FOV debug
+ reverseVideo = (Attr.defBG, Attr.defFG)
+ optVisually (fg, bg) =
+ if fg == Attr.defBG
+ then reverseVideo
+ else if bg == Attr.defFG && fg == Attr.defFG
+ then reverseVideo
+ else (fg, bg)
+ optComputationally (fg, bg) =
+ let fgSet = if fg == Attr.defFG then id else D.setFG fg
+ bgSet = if bg == Attr.defBG then id else D.setBG bg
+ in fgSet . bgSet
+ set = optComputationally . optVisually $ (fg, bg)
+ in case over (loc `shift` ((sy+1) * n, 0)) of
+ Just c -> (D.defaultAttr, c)
+ _ -> (set D.defaultAttr, char)
+ bottomLine =
+ take 40 (levelName ln ++ repeat ' ') ++
+ take 10 ("$: " ++ show gold ++ repeat ' ') ++
+ take 15 ("HP: " ++ show php ++ " (" ++ show xhp ++ ")" ++ repeat ' ') ++
+ take 15 ("T: " ++ show (time `div` 10) ++ repeat ' ')
+ disp n msg = display ((0, 0), (sy, sx)) session (dis n) msg bottomLine
+ msgs = splitMsg sx msg
+ perf k [] = perfo k ""
+ perf k [xs] = perfo k xs
+ perf k (x:xs) = disp n (x ++ more) >> getConfirm session >>= \ b ->
+ if b then perf k xs else return False
+ perfo k xs
+ | k < n - 1 = disp k xs >> getConfirm session >>= \ b ->
+ if b then perfo (k+1) xs else return False
+ | otherwise = disp k xs >> return True
+ in perf 0 msgs
View
@@ -1,6 +1,6 @@
module Display.Curses
(displayId, startup, shutdown,
- display, nextEvent, setBG, setFG, attr, Session) where
+ display, nextEvent, setBG, setFG, defaultAttr, Session) where
import UI.HSCurses.Curses as C hiding (setBold)
import qualified UI.HSCurses.CursesHelper as C
@@ -106,7 +106,7 @@ type Attr = (Maybe Attr.Color, Maybe Attr.Color)
setFG c (_, b) = (Just c, b)
setBG c (f, _) = (f, Just c)
-attr = (Nothing, Nothing)
+defaultAttr = (Nothing, Nothing)
toFColor :: Attr.Color -> C.ForegroundColor
toFColor Attr.Black = C.BlackF
View
@@ -1,6 +1,6 @@
module Display.Gtk
(displayId, startup, shutdown,
- display, nextEvent, setBG, setFG, attr, Session) where
+ display, nextEvent, setBG, setFG, defaultAttr, Session) where
import qualified Data.Binary
import Control.Monad
@@ -183,9 +183,9 @@ data AttrKey =
| BG Attr.Color
deriving (Eq, Ord)
-setBG c = (BG c :)
-setFG c = (FG c :)
-attr = []
+setBG c = (BG c :)
+setFG c = (FG c :)
+defaultAttr = []
doAttr :: TextTag -> AttrKey -> IO ()
doAttr tt (FG color) = set tt [ textTagForeground := Attr.colorToRGB color ]
Oops, something went wrong.

0 comments on commit 61fa355

Please sign in to comment.