@@ -1,25 +1,81 @@
11{-# LANGUAGE FlexibleContexts #-}
22{-# LANGUAGE GADTs #-}
33{-# LANGUAGE LambdaCase #-}
4+{-# LANGUAGE OverloadedStrings #-}
45{-# LANGUAGE RankNTypes #-}
6+{-# LANGUAGE ScopedTypeVariables #-}
57
68import Control.Monad.IO.Class
9+import Control.Monad.Trans.Reader
710import Data.Time
8−import qualified Graphics.Vty as V
11+import Graphics.Vty as V
912import Reflex
1013import Reflex.Vty
1114
15+data Region = Region
16+ { _region_left :: Int
17+ , _region_top :: Int
18+ , _region_width :: Int
19+ , _region_height :: Int
20+ }
21+ deriving (Show, Read, Eq, Ord)
22+
23+regionToDisplayRegion :: Region -> DisplayRegion
24+regionToDisplayRegion (Region _ _ w h) = (w, h)
25+
26+region :: Region -> (DisplayRegion -> Image) -> [Image]
27+region r@(Region left top width height) i =
28+ [ within r $ resize width height $ i (width, height)
29+ , within r $ wrapString width defAttr $ replicate (width * height) ' '
30+ ]
31+
32+within :: Region -> Image -> Image
33+within (Region left top width height) =
34+ translate left top . V.crop width height
35+
36+wrapString :: Int -> Attr -> String -> Image
37+wrapString maxWidth attrs = vertCat . concatMap (fmap (string attrs) . fmap (take maxWidth) . takeWhile (not . null) . iterate (drop maxWidth)) . lines
38+
39+box :: Region -> (DisplayRegion -> Image) -> [Image]
40+box r@(Region left top width height) i =
41+ let hBorder = string mempty $ replicate width '-'
42+ vBorder = wrapString 1 mempty $ replicate (height - 2) '|'
43+ internal = Region
44+ { _region_left = left + 1
45+ , _region_top = top + 1
46+ , _region_width = width - 2
47+ , _region_height = height - 2
48+ }
49+ in [ within (r { _region_height = 1 }) hBorder
50+ , within (Region left (top + 1) 1 (height - 2)) vBorder
51+ , within (Region (left + width - 1) (top + 1) 1 (height - 2)) vBorder
52+ , within (r { _region_top = top + height - 1 }) hBorder
53+ ] ++ region internal i
54+
1255guest :: forall t m. VtyApp t m
1356guest e = do
14− now <- liftIO getCurrentTime
15− ticks <- fmap show <$> tickLossy 1 now
57+ dr0@(w, h) <- displayRegion
58+ dr <- holdDyn dr0 $ fforMaybe e $ \case
59+ V.EvResize w h -> Just (w, h)
60+ _ -> Nothing
61+ let region = fmap (\(w,h) -> Region 0 0 w h) dr
62+ region1 = fmap (\(w,h) -> Region (w `div` 5) (h `div` 5) (w `div` 2) (h `div` 2)) dr
63+ region2 = fmap (\(w,h) -> Region (w `div` 4) (h `div` 4) (2 * (w `div` 3)) (2*(h `div` 3))) dr
64+ debugRegion = fmap (\(w, _) -> Region 0 0 w 3) dr
65+ events <- holdDyn "" $ show <$> e
66+ let debugOut = ffor (zipDyn events debugRegion) $ \(ev, r) ->
67+ box r $ \(w, _) -> wrapString w mempty ev
68+
1669 let shutdown = fforMaybe e $ \case
1770 V.EvKey V.KEsc _ -> Just ()
1871 _ -> Nothing
19− picture <- hold (V.picForImage $ V.string mempty "Initial") $ V.picForImage . V.string mempty <$>
20− leftmost [show <$> e, show <$> ticks]
72+ output = fmap V.picForLayers $
73+ current $ ffor ((,,) <$> region1 <*> region2 <*> debugOut) $ \(r1, r2, d) ->
74+ let b1 = box r1 (\(w, _) -> wrapString w mempty $ take 500 $ cycle ('\n' : ['a'..'z']))
75+ b2 = box r2 (\(w, _) -> wrapString w mempty $ take 500 $ cycle ('\n' : ['a'..'z']))
76+ in d ++ b2 ++ b1
2177 return $ VtyResult
22− { _vtyResult_picture = picture
78+ { _vtyResult_picture = output
2379 , _vtyResult_shutdown = shutdown
2480 }
2581