@@ -1,25 +1,81 @@
1{-# LANGUAGE FlexibleContexts #-}
1{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE GADTs #-}
2{-# LANGUAGE GADTs #-}
3{-# LANGUAGE LambdaCase #-}
3{-# LANGUAGE LambdaCase #-}
4+{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE RankNTypes #-}
5{-# LANGUAGE RankNTypes #-}
6+{-# LANGUAGE ScopedTypeVariables #-}
6import Control.Monad.IO.Class
8import Control.Monad.IO.Class
9+import Control.Monad.Trans.Reader
7import Data.Time
10import Data.Time
8−import qualified Graphics.Vty as V
11+import Graphics.Vty as V
9import Reflex
12import Reflex
10import Reflex.Vty
13import Reflex.Vty
16+ { _region_left :: Int
18+ , _region_width :: Int
19+ , _region_height :: Int
21+ deriving (Show, Read, Eq, Ord)
23+regionToDisplayRegion :: Region -> DisplayRegion
24+regionToDisplayRegion (Region _ _ w h) = (w, h)
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) ' '
32+within :: Region -> Image -> Image
33+within (Region left top width height) =
34+ translate left top . V.crop width height
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
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) '|'
44+ { _region_left = left + 1
45+ , _region_top = top + 1
46+ , _region_width = width - 2
47+ , _region_height = height - 2
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
12guest :: forall t m. VtyApp t m
55guest :: forall t m. VtyApp t m
13guest e = do
56guest e = do
14− now <- liftIO getCurrentTime
57+ dr0@(w, h) <- displayRegion
15− ticks <- fmap show <$> tickLossy 1 now
58+ dr <- holdDyn dr0 $ fforMaybe e $ \case
59+ V.EvResize w h -> Just (w, h)
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
16 let shutdown = fforMaybe e $ \case
69 let shutdown = fforMaybe e $ \case
17 V.EvKey V.KEsc _ -> Just ()
70 V.EvKey V.KEsc _ -> Just ()
18 _ -> Nothing
71 _ -> Nothing
19− picture <- hold (V.picForImage $ V.string mempty "Initial") $ V.picForImage . V.string mempty <$>
72+ output = fmap V.picForLayers $
20− leftmost [show <$> e, show <$> ticks]
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']))
21 return $ VtyResult
77 return $ VtyResult
22− { _vtyResult_picture = picture
78+ { _vtyResult_picture = output
23 , _vtyResult_shutdown = shutdown
79 , _vtyResult_shutdown = shutdown