From 999d45a6324e6870969c1f842ed1cf6738de9686 Mon Sep 17 00:00:00 2001 From: Jonathan Daugherty Date: Sun, 7 Jun 2015 18:37:36 -0700 Subject: [PATCH] During rendering, make cropping a caller responsibility to permit last-minute cropping and better support for layers; update rogue demo; add centerAbout; export Context and its lenses; use better box layout for demo UI --- programs/Main.hs | 16 ++++++++-------- programs/Rogue.hs | 18 +++++++++++------- src/Brick/Center.hs | 17 +++++++++++++++++ src/Brick/List.hs | 2 +- src/Brick/Render.hs | 1 + src/Brick/Render/Internal.hs | 35 +++++++++++++++++++---------------- 6 files changed, 57 insertions(+), 32 deletions(-) diff --git a/programs/Main.hs b/programs/Main.hs index fbf6843..19729fd 100644 --- a/programs/Main.hs +++ b/programs/Main.hs @@ -41,16 +41,16 @@ drawUI :: St -> [Render] drawUI st = [a] where (bsName, bs) = styles !! (st^.stBorderStyle) + box = borderWithLabel bs bsName $ + (hLimit 25 ( + vBox [ (vLimit 1 $ useAttr (cyan `on` blue) $ drawEditor (st^.stEditor), High) + , (hBorder bs, Low) + , (vLimit 10 $ drawList (st^.stList), High) + ] + )) a = translate (st^.stTrans) $ vCenter $ - (hCenter $ borderWithLabel bs bsName $ - (hLimit 25 ( - (vLimit 1 $ useAttr (cyan `on` blue) $ drawEditor (st^.stEditor)) - <<= - hBorder bs - =>> - (vLimit 10 $ drawList (st^.stList)) - ))) + (hCenter box) <<= (vLimit 1 $ vPad ' ') =>> diff --git a/programs/Rogue.hs b/programs/Rogue.hs index 3e26d9b..1872927 100644 --- a/programs/Rogue.hs +++ b/programs/Rogue.hs @@ -1,7 +1,7 @@ {-# LANGUAGE TemplateHaskell #-} module Main where -import Graphics.Vty +import Graphics.Vty hiding (translate) import Data.Array import Data.Default (def) @@ -12,7 +12,11 @@ import Control.Monad import System.Random import System.Exit -import Brick +import Brick.Main +import Brick.Render +import Brick.Border +import Brick.Core +import Brick.Center data Player = Player { playerCoord :: Coord @@ -113,17 +117,17 @@ movePlayer world dx dy = do EmptySpace -> world { player = Player (x',y') } _ -> world -updateDisplay :: World -> [Widget] +updateDisplay :: World -> [Render] updateDisplay world = [ info, playerLayer, geoLayer ] where - info = vBox [ hCentered $ txt "Move with the arrows keys. Press ESC to exit." - , hBorder '-' + info = vBox [ (hCenter $ txt "Move with the arrows keys. Press ESC to exit.", High) + , (hBorder ascii, High) ] (px, py) = playerCoord $ player world playerLoc = Location (px, py) theLevel = level world - playerLayer = centeredAbout playerLoc $ translated playerLoc $ liftVty (char pieceA '@') - geoLayer = centeredAbout playerLoc $ liftVty $ levelGeoImage theLevel + playerLayer = centerAbout playerLoc $ translate playerLoc $ raw (char pieceA '@') + geoLayer = centerAbout playerLoc $ raw $ levelGeoImage theLevel imageForGeo :: LevelPiece -> Image imageForGeo EmptySpace = char (defAttr `withBackColor` green) ' ' diff --git a/src/Brick/Center.hs b/src/Brick/Center.hs index fe16abf..a693397 100644 --- a/src/Brick/Center.hs +++ b/src/Brick/Center.hs @@ -4,10 +4,15 @@ module Brick.Center , vCenter , vCenterWith , center + , centerAbout ) where +import Control.Lens ((^.)) +import Control.Monad.Trans.Reader + import Brick.Render +import Brick.Core hCenter :: Render -> Render hCenter = hCenterWith ' ' @@ -31,3 +36,15 @@ vCenterWith c p = center :: Render -> Render center = vCenter . hCenter + +centerAbout :: Location -> Render -> Render +centerAbout (Location (offW, offH)) p = do + -- Compute translation offset so that loc is in the middle of the + -- rendering area + c <- ask + let centerW = c^.w `div` 2 + centerH = c^.h `div` 2 + off = Location ( centerW - offW + , centerH - offH + ) + translate off p diff --git a/src/Brick/List.hs b/src/Brick/List.hs index 5d3d480..452e61c 100644 --- a/src/Brick/List.hs +++ b/src/Brick/List.hs @@ -44,7 +44,7 @@ drawList :: List e -> Render drawList l = theList where theList = viewport "list" Vertical $ body - body = (vBox pairs <<= vPad ' ') <<+ hPad ' ' + body = (vBox pairs <=> vPad ' ') <+> hPad ' ' pairs = (, High) <$> (drawListElements l) drawListElements :: List e -> [Render] diff --git a/src/Brick/Render.hs b/src/Brick/Render.hs index 0f6f5bf..1dd2efc 100644 --- a/src/Brick/Render.hs +++ b/src/Brick/Render.hs @@ -1,5 +1,6 @@ module Brick.Render ( Render + , Context, w, h , Priority(..) , (=>>), (<<=), (<=>) , (+>>), (<<+), (<+>) diff --git a/src/Brick/Render/Internal.hs b/src/Brick/Render/Internal.hs index 6517d7f..10d7296 100644 --- a/src/Brick/Render/Internal.hs +++ b/src/Brick/Render/Internal.hs @@ -13,6 +13,7 @@ module Brick.Render.Internal , Priority(..) , renderFinal , Render + , Context, w, h , ViewportType(..) @@ -114,7 +115,7 @@ renderFinal :: [Render] -> (RenderState, V.Picture, Maybe CursorLocation) renderFinal layerRenders sz chooseCursor rs = (newRS, pic, theCursor) where - (layerResults, newRS) = flip runState rs $ sequence $ (\p -> runReaderT p ctx) <$> layerRenders + (layerResults, newRS) = flip runState rs $ sequence $ (\p -> runReaderT p ctx) <$> (cropToContext <$> layerRenders) ctx = Context V.defAttr (fst sz) (snd sz) pic = V.picForLayers $ uncurry V.resize sz <$> (^.image) <$> layerResults layerCursors = (^.cursors) <$> layerResults @@ -137,9 +138,7 @@ unrestricted = 1000 txt :: String -> Render txt s = do c <- ask - return $ if c^.w > 0 && c^.h > 0 - then def & image .~ (V.crop (c^.w) (c^.h) $ V.string (c^.attr) s) - else def + return $ def & image .~ (V.string (c^.attr) s) hPad :: Char -> Render hPad ch = do @@ -179,8 +178,7 @@ hBox pairs = do heightPerLow = maximum $ (^._2.image.(to V.imageHeight)) <$> renderedHis renderLow (i, (prim, _)) = let padding = (if i == 0 then padFirst else 0) - in (i,) <$> (withReaderT (\v -> v & w .~ widthPerLow + padding - & h .~ heightPerLow) prim) + in (i,) <$> (vLimit heightPerLow $ hLimit (widthPerLow + padding) $ cropToContext prim) renderedLows <- mapM renderLow lows @@ -197,7 +195,7 @@ hBox pairs = do offWidth = sum $ take i allWidths in (addCursorOffset off result)^.cursors - return $ Result (V.horizCat allImages) (concat allTranslatedCursors) (concat allTranslatedVRs) + cropToContext $ return $ Result (V.horizCat allImages) (concat allTranslatedCursors) (concat allTranslatedVRs) vBox :: [(Render, Priority)] -> Render vBox pairs = do @@ -217,8 +215,7 @@ vBox pairs = do widthPerLow = maximum $ (^._2.image.(to V.imageWidth)) <$> renderedHis renderLow (i, (prim, _)) = let padding = if i == 0 then padFirst else 0 - in (i,) <$> (withReaderT (\v -> v & w .~ widthPerLow - & h .~ (heightPerLow + padding)) prim) + in (i,) <$> (vLimit (heightPerLow + padding) $ hLimit widthPerLow $ cropToContext prim) renderedLows <- mapM renderLow lows @@ -235,15 +232,15 @@ vBox pairs = do offHeight = sum $ take i allHeights in (addCursorOffset off result)^.cursors - return $ Result (V.vertCat allImages) (concat allTranslatedCursors) (concat allTranslatedVRs) + cropToContext $ return $ Result (V.vertCat allImages) (concat allTranslatedCursors) (concat allTranslatedVRs) -- xxx crop cursors and VRs hLimit :: Int -> Render -> Render -hLimit w' = withReaderT (& w .~ w') +hLimit w' p = withReaderT (& w .~ w') $ cropToContext p -- xxx crop cursors and VRs vLimit :: Int -> Render -> Render -vLimit h' = withReaderT (& h .~ h') +vLimit h' p = withReaderT (& h .~ h') $ cropToContext p useAttr :: V.Attr -> Render -> Render useAttr a = withReaderT (& attr .~ a) @@ -252,16 +249,22 @@ raw :: V.Image -> Render raw img = do c <- ask return $ if c^.w > 0 && c^.h > 0 - then def & image .~ (V.crop (c^.w) (c^.h) img) + then def & image .~ img else def +-- xxx find another name that doesn't clash with Vty's translate function translate :: Location -> Render -> Render translate (Location (tw,th)) p = do result <- p - c <- ask return $ addCursorOffset (Location (tw, th)) $ addVisibilityOffset (Location (tw, th)) $ - result & image %~ (V.crop (c^.w) (c^.h) . V.translate tw th) + result & image %~ (V.translate tw th) + +cropToContext :: Render -> Render +cropToContext p = do + result <- p + c <- ask + return $ result & image %~ (V.crop (c^.w) (c^.h)) cropLeftBy :: Int -> Render -> Render cropLeftBy cols p = do @@ -347,7 +350,7 @@ viewport vpname typ p = do -- Return the translated result with the visibility requests -- discarded - return $ translated & visibilityRequests .~ mempty + cropToContext $ return $ translated & visibilityRequests .~ mempty scrollToView :: ViewportType -> VisibilityRequest -> Viewport -> Viewport scrollToView typ rq vp = vp & theStart .~ newStart