@@ -1,8 +1,5 @@
1−{-# LANGUAGE RankNTypes #-}
2-- Copyright Corey O'Connor
1-- Copyright Corey O'Connor
3−{-# LANGUAGE TemplateHaskell #-}
4{-# LANGUAGE BangPatterns #-}
2{-# LANGUAGE BangPatterns #-}
5−{-# LANGUAGE ExistentialQuantification #-}
6{-# LANGUAGE NamedFieldPuns #-}
3{-# LANGUAGE NamedFieldPuns #-}
7{-# LANGUAGE GADTs #-}
4{-# LANGUAGE GADTs #-}
8{-# LANGUAGE ScopedTypeVariables #-}
5{-# LANGUAGE ScopedTypeVariables #-}
@@ -20,33 +17,18 @@
20module Graphics.Vty.Span
17module Graphics.Vty.Span
23−import Graphics.Vty.Image
24−import Graphics.Vty.Image.Internal
25−import Graphics.Vty.Picture
26import Graphics.Vty.DisplayRegion
20import Graphics.Vty.DisplayRegion
27−
21+import Graphics.Vty.Image
28−import Control.Applicative
29−import Control.Lens hiding ( op )
30−import Control.Monad.Reader
31−import Control.Monad.State.Strict hiding ( state )
32−import Control.Monad.ST.Strict hiding ( unsafeIOToST )
34import Data.Vector (Vector)
23import Data.Vector (Vector)
35import qualified Data.Vector as Vector hiding ( take, replicate )
24import qualified Data.Vector as Vector hiding ( take, replicate )
36−import Data.Vector.Mutable ( MVector(..))
37−import qualified Data.Vector.Mutable as Vector
39import qualified Data.ByteString as BS
26import qualified Data.ByteString as BS
40import qualified Data.Text as T
27import qualified Data.Text as T
41import qualified Data.Text.Encoding as T
28import qualified Data.Text.Encoding as T
42−import qualified Data.Text.Lazy as TL
44-- | This represents an operation on the terminal. Either an attribute change or the output of a
30-- | This represents an operation on the terminal. Either an attribute change or the output of a
45-- text string.
31-- text string.
47−-- todo: This type may need to be restructured to increase sharing in the bytestring
49−-- todo: Make foldable
50data SpanOp =
32data SpanOp =
51 AttributeChange !Attr
33 AttributeChange !Attr
52 -- | a span of UTF-8 text occupies a specific number of screen space columns. A single UTF
34 -- | a span of UTF-8 text occupies a specific number of screen space columns. A single UTF
@@ -69,10 +51,6 @@ data DisplayOps = DisplayOps
69-- | vector of span operation vectors. One per row of the screen.
51-- | vector of span operation vectors. One per row of the screen.
70type RowOps = Vector SpanOps
52type RowOps = Vector SpanOps
72−type MRowOps s = MVector s SpanOps
74−type MSpanOps s = MVector s SpanOp
76instance Show DisplayOps where
54instance Show DisplayOps where
77 show (DisplayOps _ the_row_ops)
55 show (DisplayOps _ the_row_ops)
78 = "{ " ++ (show $ Vector.map (\ops -> show ops ++ "; " ) the_row_ops) ++ " }"
56 = "{ " ++ (show $ Vector.map (\ops -> show ops ++ "; " ) the_row_ops) ++ " }"
@@ -81,35 +59,6 @@ instance Show SpanOp where
81 show (AttributeChange attr) = show attr
59 show (AttributeChange attr) = show attr
82 show (TextSpan ow cw _) = "TextSpan " ++ show ow ++ " " ++ show cw
60 show (TextSpan ow cw _) = "TextSpan " ++ show ow ++ " " ++ show cw
84−-- transform plus clip. More or less.
85−data BlitState = BlitState
86− -- we always snoc to the operation vectors. Thus the column_offset = length of row at row_offset
87− { _column_offset :: Int
89− -- clip coordinate space is in image space. Which means it's >= 0 and < image_width.
90− , _skip_columns :: Int
91− -- >= 0 and < image_height
93− -- includes consideration of skip_columns. In display space.
94− -- The number of columns from the next column to be defined to the end of the display for the
96− , _remaining_columns :: Int
97− -- includes consideration of skip_rows. In display space.
98− , _remaining_rows :: Int
101−makeLenses ''BlitState
103−data BlitEnv s = BlitEnv
105− , _region :: DisplayRegion
106− , _mrow_ops :: MRowOps s
111−type BlitM s a = ReaderT (BlitEnv s) (StateT BlitState (ST s)) a
113-- | Number of columns the DisplayOps are defined for
62-- | Number of columns the DisplayOps are defined for
114span_ops_columns :: DisplayOps -> Int
63span_ops_columns :: DisplayOps -> Int
115span_ops_columns ops = region_width $ effected_region ops
64span_ops_columns ops = region_width $ effected_region ops
@@ -137,237 +86,3 @@ columns_to_char_offset cx (TextSpan _ _ utf8_str) =
137 in wcswidth (take cx str)
86 in wcswidth (take cx str)
138columns_to_char_offset _cx _ = error "columns_to_char_offset applied to span op without width"
87columns_to_char_offset _cx _ = error "columns_to_char_offset applied to span op without width"
140−-- | Produces the span ops that will render the given picture, possibly cropped or padded, into the
142−spans_for_pic :: Picture -> DisplayRegion -> DisplayOps
143−spans_for_pic pic r = DisplayOps r $ Vector.create (combined_spans_for_layers pic r)
145−-- | Produces the span ops for each layer then combines them.
147−-- TODO: a fold over a builder function. start with span ops that are a bg fill of the entire
149−combined_spans_for_layers :: Picture -> DisplayRegion -> ST s (MRowOps s)
150−combined_spans_for_layers pic r = do
151− layer_ops <- mapM (\layer -> build_spans layer r (pic_background pic)) (pic_layers pic)
153− [] -> fail "empty picture"
155− _ -> fail "TODO: picture with more than one layer not supported"
157−-- | Builds a vector of row operations that will output the given picture to the terminal.
159−-- Crops to the given display region.
161−-- TODO: I'm pretty sure there is an algorithm that does not require a mutable buffer.
162−build_spans :: Image -> DisplayRegion -> Background -> ST s (MRowOps s)
163−build_spans image out_region background = do
164− -- First we create a mutable vector for each rows output operations.
165− out_ops <- Vector.replicate (region_height out_region) Vector.empty
166− -- \todo I think building the span operations in display order would provide better performance.
167− -- However, I got stuck trying to implement an algorithm that did this. This will be considered
168− -- as a possible future optimization.
170− -- A depth first traversal of the image is performed. ordered according to the column range
171− -- defined by the image from least to greatest. The output row ops will at least have the
172− -- region of the image specified. Iterate over all output rows and output background fills for
173− -- all unspecified columns.
175− -- The images are made into span operations from left to right. It's possible that this could
176− -- easily be made to assure top to bottom output as well.
177− when (region_height out_region > 0 && region_width out_region > 0) $ do
178− -- The ops builder recursively descends the image and outputs span ops that would
179− -- display that image. The number of columns remaining in this row before exceeding the
180− -- bounds is also provided. This is used to clip the span ops produced to the display.
182− start_image_build image
183− -- Fill in any unspecified columns with the background pattern.
184− forM_ [0 .. (region_height out_region - 1)] (add_row_completion out_region)
185− init_env = BlitEnv background out_region out_ops
186− init_state = BlitState 0 0 0 0 (region_width out_region) (region_height out_region)
187− _ <- runStateT (runReaderT full_build init_env) init_state
191−-- | Add the operations required to build a given image to the current set of row operations
192−-- returns the number of columns and rows contributed to the output.
193−start_image_build :: Image -> BlitM s ()
194−start_image_build image = do
195− out_of_bounds <- is_out_of_bounds <$> get
196− when (not out_of_bounds) $ add_maybe_clipped image
198−is_out_of_bounds :: BlitState -> Bool
200− | s ^. remaining_columns <= 0 = True
201− | s ^. remaining_rows <= 0 = True
204−-- TODO: prove skip_columns, skip_rows == 0
205−-- TODO: prove remaining_columns >= image_width
206−-- TODO: prove remaining_rows >= image_height
207−add_unclipped :: Image -> BlitM s ()
208−add_unclipped EmptyImage = return ()
209−add_unclipped (HorizText a text_str _ow _cw) = do
210− use row_offset >>= snoc_op (AttributeChange a)
211− add_unclipped_text text_str
212−add_unclipped (HorizJoin part_left part_right _ow _oh) = do
213− -- TODO: push into env and use
215− add_unclipped part_left
217− add_unclipped part_right
218−add_unclipped (VertJoin part_top part_bottom _ow _oh) = do
220− add_unclipped part_top
221− row_offset .= y + image_height part_top
222− add_unclipped part_bottom
223− -- TODO: assumes background character is 1 column
224−add_unclipped (BGFill ow oh) = do
225− Background c a <- view bg
227− let op = TextSpan ow ow (T.encodeUtf8 $ T.replicate (fromIntegral ow) (T.singleton c))
228− forM_ [y..y+oh-1] $ \row -> do
229− snoc_op (AttributeChange a) row
231−-- TODO: we know it's clipped actually, the equations that are exposed that introduce a
232−-- Crop all assure the image exceeds the crop in the relevant direction.
233−add_unclipped CropRight {cropped_image, output_width} = do
234− remaining_columns .= output_width
235− add_maybe_clipped cropped_image
236−add_unclipped CropLeft {cropped_image, left_skip} = do
237− skip_columns .= left_skip
238− add_maybe_clipped cropped_image
239−add_unclipped CropBottom {cropped_image, output_height} = do
240− remaining_rows .= output_height
241− add_maybe_clipped cropped_image
242−add_unclipped CropTop {cropped_image, top_skip} = do
243− skip_rows .= top_skip
244− add_maybe_clipped cropped_image
246−-- TODO: prove this cannot be called in an out of bounds case.
247−add_maybe_clipped :: forall s . Image -> BlitM s ()
248−add_maybe_clipped EmptyImage = return ()
249−add_maybe_clipped (HorizText a text_str ow _cw) = do
250− -- TODO: assumption that text spans are only 1 row high.
253− use row_offset >>= snoc_op (AttributeChange a)
254− left_clip <- use skip_columns
255− right_clip <- use remaining_columns
256− let left_clipped = left_clip > 0
257− right_clipped = (ow - left_clip) > right_clip
258− if left_clipped || right_clipped
259− then let text_str' = clip_text text_str left_clip right_clip
260− in add_unclipped_text text_str'
261− else add_unclipped_text text_str
262−add_maybe_clipped (VertJoin top_image bottom_image _ow oh) = do
263− add_maybe_clipped_join "vert_join" skip_rows remaining_rows row_offset
264− (image_height top_image)
268−add_maybe_clipped (HorizJoin left_image right_image ow _oh) = do
269− add_maybe_clipped_join "horiz_join" skip_columns remaining_columns column_offset
270− (image_width left_image)
274−add_maybe_clipped BGFill {output_width, output_height} = do
276− let output_width' = min (output_width - s^.skip_columns) (s^.remaining_columns)
277− output_height' = min (output_height - s^.skip_rows ) (s^.remaining_rows)
278− add_unclipped (BGFill output_width' output_height')
279−add_maybe_clipped CropRight {cropped_image, output_width} = do
280− remaining_columns .= output_width
281− add_maybe_clipped cropped_image
282−add_maybe_clipped CropLeft {cropped_image, left_skip} = do
283− skip_columns += left_skip
284− add_maybe_clipped cropped_image
285−add_maybe_clipped CropBottom {cropped_image, output_height} = do
286− remaining_rows .= output_height
287− add_maybe_clipped cropped_image
288−add_maybe_clipped CropTop {cropped_image, top_skip} = do
289− skip_rows += top_skip
290− add_maybe_clipped cropped_image
292−add_maybe_clipped_join :: forall s . String
293− -> Lens BlitState BlitState Int Int
294− -> Lens BlitState BlitState Int Int
295− -> Lens BlitState BlitState Int Int
301−add_maybe_clipped_join name skip remaining offset i0_dim i0 i1 size = do
303− when (state^.remaining == 0) $ fail $ name ++ " with remaining == 0"
305− s | s >= size -> fail $ name ++ " on fully clipped"
306− -- TODO: check if clipped in other dim. if not use add_unclipped
307− | s == 0 -> case state^.remaining of
308− r | r > i0_dim -> do
309− add_maybe_clipped i0
310− put $ state & offset +~ i0_dim & remaining -~ i0_dim
311− add_maybe_clipped i1
312− | otherwise -> add_maybe_clipped i0
314− put $ state & skip -~ i0_dim
315− add_maybe_clipped i1
316− | otherwise -> case i0_dim - s of
317− i0_dim' | state^.remaining <= i0_dim' -> add_maybe_clipped i0
319− add_maybe_clipped i0
320− put $ state & offset +~ i0_dim' & remaining -~ i0_dim'
321− add_maybe_clipped i1
323−-- TODO: store a skip list in HorizText(?)
324−-- TODO: represent display strings containing chars that are not 1 column chars as a separate
325−-- display string value?
326−-- TODO: assumes max column width is 2
327−clip_text :: DisplayText -> Int -> Int -> DisplayText
328−clip_text txt left_skip right_clip =
329− -- CPS would clarify this I think
330− let (to_drop,pad_prefix) = clip_for_char_width left_skip txt 0
331− txt' = if pad_prefix then TL.cons '…' (TL.drop (to_drop+1) txt) else TL.drop to_drop txt
332− (to_take,pad_suffix) = clip_for_char_width right_clip txt' 0
333− txt'' = TL.append (TL.take to_take txt') (if pad_suffix then TL.singleton '…' else TL.empty)
334− clip_for_char_width 0 _ n = (n, False)
335− clip_for_char_width w t n
336− | w < cw = (n, True)
337− | w == cw = (n+1, False)
338− | w > cw = clip_for_char_width (w - cw) (TL.tail t) (n + 1)
339− where cw = safe_wcwidth (TL.head t)
340− clip_for_char_width _ _ _ = error "clip_for_char_width applied to undefined"
343−add_unclipped_text :: DisplayText -> BlitM s ()
344−add_unclipped_text txt = do
345− let op = TextSpan used_display_columns
346− (fromIntegral $ TL.length txt)
347− (T.encodeUtf8 $ TL.toStrict txt)
348− used_display_columns = wcswidth $ TL.unpack txt
349− use row_offset >>= snoc_op op
351−-- todo: If there is no background pattern defined then skip to next line.
352−-- todo: assumes background character is 1 column
353−add_row_completion :: DisplayRegion -> Int -> BlitM s ()
354−add_row_completion display_region row = do
355− all_row_ops <- view mrow_ops
356− Background c a <- view bg
357− row_ops <- lift $ lift $ Vector.read all_row_ops row
358− let end_x = span_ops_effected_columns row_ops
359− when (end_x < region_width display_region) $ do
360− let ow = region_width display_region - end_x
361− op = TextSpan ow ow (T.encodeUtf8 $ T.replicate (fromIntegral ow) (T.singleton c))
362− snoc_op (AttributeChange a) row
365−-- | snocs the operation to the operations for the given row.
366−snoc_op :: SpanOp -> Int -> BlitM s ()
367−snoc_op !op !row = do
368− the_mrow_ops <- view mrow_ops
370− ops <- Vector.read the_mrow_ops row
371− let ops' = Vector.snoc ops op
372− Vector.write the_mrow_ops row ops'