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

@@ -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 ' ')
               =>>

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) ' '

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

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]

src/Brick/Render.hs

@@ -1,5 +1,6 @@
 module Brick.Render
   ( Render
+  , Context, w, h
   , Priority(..)
   , (=>>), (<<=), (<=>)
   , (+>>), (<<+), (<+>)

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