@@ -1,8 +1,5 @@
1−{-# LANGUAGE RankNTypes #-}
21-- Copyright Corey O'Connor
3−{-# LANGUAGE TemplateHaskell #-}
42{-# LANGUAGE BangPatterns #-}
5−{-# LANGUAGE ExistentialQuantification #-}
63{-# LANGUAGE NamedFieldPuns #-}
74{-# LANGUAGE GADTs #-}
85{-# LANGUAGE ScopedTypeVariables #-}
@@ -20,33 +17,18 @@
2017module Graphics.Vty.Span
2118 where
2219
23−import Graphics.Vty.Image
24−import Graphics.Vty.Image.Internal
25−import Graphics.Vty.Picture
2620import Graphics.Vty.DisplayRegion
27−
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 )
21+import Graphics.Vty.Image
3322
3423import Data.Vector (Vector)
3524import qualified Data.Vector as Vector hiding ( take, replicate )
36−import Data.Vector.Mutable ( MVector(..))
37−import qualified Data.Vector.Mutable as Vector
3825
3926import qualified Data.ByteString as BS
4027import qualified Data.Text as T
4128import qualified Data.Text.Encoding as T
42−import qualified Data.Text.Lazy as TL
4329
4430-- | This represents an operation on the terminal. Either an attribute change or the output of a
4531-- text string.
46−--
47−-- todo: This type may need to be restructured to increase sharing in the bytestring
48−--
49−-- todo: Make foldable
5032data SpanOp =
5133 AttributeChange !Attr
5234 -- | a span of UTF-8 text occupies a specific number of screen space columns. A single UTF
@@ -69,10 +51,6 @@ data DisplayOps = DisplayOps
6951-- | vector of span operation vectors. One per row of the screen.
7052type RowOps = Vector SpanOps
7153
72−type MRowOps s = MVector s SpanOps
73−
74−type MSpanOps s = MVector s SpanOp
75−
7654instance Show DisplayOps where
7755 show (DisplayOps _ the_row_ops)
7856 = "{ " ++ (show $ Vector.map (\ops -> show ops ++ "; " ) the_row_ops) ++ " }"
@@ -81,35 +59,6 @@ instance Show SpanOp where
8159 show (AttributeChange attr) = show attr
8260 show (TextSpan ow cw _) = "TextSpan " ++ show ow ++ " " ++ show cw
8361
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
88− , _row_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
92− , _skip_rows :: Int
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
95− -- row.
96− , _remaining_columns :: Int
97− -- includes consideration of skip_rows. In display space.
98− , _remaining_rows :: Int
99− }
100−
101−makeLenses ''BlitState
102−
103−data BlitEnv s = BlitEnv
104− { _bg :: Background
105− , _region :: DisplayRegion
106− , _mrow_ops :: MRowOps s
107− }
108−
109−makeLenses ''BlitEnv
110−
111−type BlitM s a = ReaderT (BlitEnv s) (StateT BlitState (ST s)) a
112−
11362-- | Number of columns the DisplayOps are defined for
11463span_ops_columns :: DisplayOps -> Int
11564span_ops_columns ops = region_width $ effected_region ops
@@ -137,237 +86,3 @@ columns_to_char_offset cx (TextSpan _ _ utf8_str) =
13786 in wcswidth (take cx str)
13887columns_to_char_offset _cx _ = error "columns_to_char_offset applied to span op without width"
13988
140−-- | Produces the span ops that will render the given picture, possibly cropped or padded, into the
141−-- specified region.
142−spans_for_pic :: Picture -> DisplayRegion -> DisplayOps
143−spans_for_pic pic r = DisplayOps r $ Vector.create (combined_spans_for_layers pic r)
144−
145−-- | Produces the span ops for each layer then combines them.
146−--
147−-- TODO: a fold over a builder function. start with span ops that are a bg fill of the entire
148−-- region.
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)
152− case layer_ops of
153− [] -> fail "empty picture"
154− [ops] -> return ops
155− _ -> fail "TODO: picture with more than one layer not supported"
156−
157−-- | Builds a vector of row operations that will output the given picture to the terminal.
158−--
159−-- Crops to the given display region.
160−--
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.
169− --
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.
174− --
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.
181− let full_build = do
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
188− return ()
189− return out_ops
190−
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
197−
198−is_out_of_bounds :: BlitState -> Bool
199−is_out_of_bounds s
200− | s ^. remaining_columns <= 0 = True
201− | s ^. remaining_rows <= 0 = True
202− | otherwise = False
203−
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
214− y <- use row_offset
215− add_unclipped part_left
216− row_offset .= y
217− add_unclipped part_right
218−add_unclipped (VertJoin part_top part_bottom _ow _oh) = do
219− y <- use row_offset
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
226− y <- use row_offset
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
230− snoc_op op 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
245−
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.
251− s <- use skip_rows
252− when (s < 1) $ do
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)
265− top_image
266− bottom_image
267− oh
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)
271− left_image
272− right_image
273− ow
274−add_maybe_clipped BGFill {output_width, output_height} = do
275− s <- get
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
291−
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
296− -> Int
297− -> Image
298− -> Image
299− -> Int
300− -> BlitM s ()
301−add_maybe_clipped_join name skip remaining offset i0_dim i0 i1 size = do
302− state <- get
303− when (state^.remaining == 0) $ fail $ name ++ " with remaining == 0"
304− case state^.skip of
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
313− | s >= i0_dim -> do
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
318− | otherwise -> do
319− add_maybe_clipped i0
320− put $ state & offset +~ i0_dim' & remaining -~ i0_dim'
321− add_maybe_clipped i1
322−
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"
341− in txt''
342−
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
350−
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
363− snoc_op op row
364−
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
369− lift $ lift $ do
370− ops <- Vector.read the_mrow_ops row
371− let ops' = Vector.snoc ops op
372− Vector.write the_mrow_ops row ops'
373−