@@ -1,3 +1,4 @@
1+{-# LANGUAGE RankNTypes #-}
12-- Copyright Corey O'Connor
23{-# LANGUAGE TemplateHaskell #-}
34{-# LANGUAGE BangPatterns #-}
@@ -25,6 +26,7 @@ import Graphics.Vty.Picture
2526import Graphics.Vty.DisplayRegion
2627import Graphics.Text.Width
2728
29+import Control.Applicative
2830import Control.Lens
2931import Control.Monad ( forM_ )
3032import Control.Monad.Reader
@@ -38,9 +40,12 @@ import qualified Data.Vector as Vector hiding ( take, replicate )
3840import Data.Vector.Mutable ( MVector(..))
3941import qualified Data.Vector.Mutable as Vector
4042
43+import qualified Data.ByteString as BS
4144import qualified Data.ByteString.Lazy as BL
42−import qualified Data.ByteString.Lazy.Internal as BLInt
45+import qualified Data.ByteString.Lazy.Internal as BL
4346import qualified Data.Foldable as Foldable
47+import qualified Data.Text as T
48+import qualified Data.Text.Encoding as T
4449import qualified Data.Text.Lazy as TL
4550import qualified Data.Text.Lazy.Encoding as TL
4651import Data.Word
@@ -58,7 +63,7 @@ data SpanOp =
5863 -- | a span of UTF-8 text occupies a specific number of screen space columns. A single UTF
5964 -- character does not necessarially represent 1 colunm. See Codec.Binary.UTF8.Width
6065 -- TextSpan [output width in columns] [number of characters] [data]
61− | TextSpan !Int !Int BL.ByteString
66+ | TextSpan !Int !Int BS.ByteString
6267 deriving Eq
6368
6469-- | vector of span operations. executed in succession. This represents the operations required to
@@ -67,7 +72,6 @@ data SpanOp =
6772-- color is changed.
6873type SpanOps = Vector SpanOp
6974
70−
7175data DisplayOps = DisplayOps
7276 { effected_region :: DisplayRegion
7377 , display_ops :: RowOps
@@ -91,7 +95,8 @@ instance Show SpanOp where
9195-- transform plus clip. More or less.
9296data BlitState = BlitState
9397 -- we always snoc to the operation vectors. Thus the column_offset = length of row at row_offset
94− { _row_offset :: Int
98+ { _column_offset :: Int
99+ , _row_offset :: Int
95100 -- clip coordinate space is in image space. Which means it's >= 0 and < image_width.
96101 , _skip_columns :: Int
97102 -- >= 0 and < image_height
@@ -117,15 +122,15 @@ makeLenses ''BlitEnv
117122type BlitM s a = ReaderT (BlitEnv s) (StateT BlitState (ST s)) a
118123
119124-- | Number of columns the DisplayOps are defined for
120−span_ops_columns :: DisplayOps -> Word
125+span_ops_columns :: DisplayOps -> Int
121126span_ops_columns ops = region_width $ effected_region ops
122127
123128-- | Number of rows the DisplayOps are defined for
124−span_ops_rows :: DisplayOps -> Word
129+span_ops_rows :: DisplayOps -> Int
125130span_ops_rows ops = region_height $ effected_region ops
126131
127132-- | The number of columns a SpanOps effects.
128−span_ops_effected_columns :: SpanOps -> Word
133+span_ops_effected_columns :: SpanOps -> Int
129134span_ops_effected_columns in_ops = Vector.foldl' span_ops_effected_columns' 0 in_ops
130135 where
131136 span_ops_effected_columns' t (TextSpan w _ _ ) = t + w
@@ -139,7 +144,7 @@ span_op_has_width _ = Nothing
139144-- | returns the number of columns to the character at the given position in the span op
140145columns_to_char_offset :: Int -> SpanOp -> Int
141146columns_to_char_offset cx (TextSpan _ _ utf8_str) =
142− let str = TL.unpack (TL.decodeUtf8 utf8_str)
147+ let str = T.unpack (T.decodeUtf8 utf8_str)
143148 in wcswidth (take cx str)
144149columns_to_char_offset _cx _ = error "columns_to_char_offset applied to span op without width"
145150
@@ -166,24 +171,18 @@ build_spans pic region = do
166171 --
167172 -- The images are made into span operations from left to right. It's possible that this could
168173 -- easily be made to assure top to bottom output as well.
169− if region_height region > 0
170− then do
171− -- The ops builder recursively descends the image and outputs span ops that would
172− -- display that image. The number of columns remaining in this row before exceeding the
173− -- bounds is also provided. This is used to clip the span ops produced to the display.
174− -- The skip dimensions provided do....???
175− _ <- runStateT (runReaderT (start_image_build $ pic_image pic)
176− (BlitEnv (pic_background pic) region mrow_ops)
177− )
178− (BlitState 0 0 0 0 (region_width region) (region_height region))
179− -- Fill in any unspecified columns with the background pattern.
180− -- todo: If there is no background pattern defined then skip
181− forM_ [0 .. (region_height region - 1)] $! \row -> do
182− end_x <- Vector.read mrow_ops row >>= return . span_ops_effected_columns
183− if end_x < region_width region
184− then snoc_bg_fill mrow_ops (pic_background pic) (region_width region - end_x) row
185− else return ()
186− else return ()
174+ when (region_height region > 0 && region_width region > 0) $ do
175+ -- The ops builder recursively descends the image and outputs span ops that would
176+ -- display that image. The number of columns remaining in this row before exceeding the
177+ -- bounds is also provided. This is used to clip the span ops produced to the display.
178+ let full_build = do
179+ start_image_build $ pic_image pic
180+ -- Fill in any unspecified columns with the background pattern.
181+ forM_ [0 .. (region_height region - 1)] add_row_completion
182+ init_env = BlitEnv (pic_background pic) region mrow_ops
183+ init_state = BlitState 0 0 0 0 (region_width region) (region_height region)
184+ _ <- runStateT (runReaderT full_build init_env) init_state
185+ return ()
187186 return mrow_ops
188187
189188-- | Add the operations required to build a given image to the current set of row operations
@@ -191,14 +190,12 @@ build_spans pic region = do
191190start_image_build :: Image -> BlitM s ()
192191start_image_build image = do
193192 out_of_bounds <- is_out_of_bounds image <$> get
194− if out_of_bounds
195− then return (0,0)
196− else add_maybe_clipped image
193+ when (not out_of_bounds) $ add_maybe_clipped image
197194
198195is_out_of_bounds :: Image -> BlitState -> Bool
199196is_out_of_bounds image s
200197 | s ^. remaining_columns <= 0 = True
201− | s ^. remain_rows <= 0 = True
198+ | s ^. remaining_rows <= 0 = True
202199 | otherwise = False
203200
204201-- TODO: prove skip_columns, skip_rows == 0
@@ -206,7 +203,7 @@ is_out_of_bounds image s
206203-- TODO: prove remaining_rows >= image_height
207204add_unclipped :: Image -> BlitM s ()
208205add_unclipped EmptyImage = return ()
209−add_unclipped (HorizText text_str _ow _cw) = do
206+add_unclipped (HorizText a text_str _ow _cw) = do
210207 use row_offset >>= snoc_op (AttributeChange a)
211208 add_unclipped_text text_str
212209add_unclipped (HorizJoin part_left part_right _ow _oh) = do
@@ -224,8 +221,10 @@ add_unclipped (VertJoin part_top part_bottom _ow _oh) = do
224221add_unclipped (BGFill ow oh) = do
225222 Background c a <- view bg
226223 y <- use row_offset
227− let op = TextSpan ow ow (TL.replicate (fromIntegral ow) c)
228− forM_ [y..y+oh] $ snoc_op op
224+ let op = TextSpan ow ow (T.encodeUtf8 $ T.replicate (fromIntegral ow) (T.singleton c))
225+ forM_ [y..y+oh] $ \row -> do
226+ snoc_op (AttributeChange a) row
227+ snoc_op op row
229228-- TODO: we know it's clipped actually, the equations that are exposed that introduce a
230229-- Crop all assure the image exceeds the crop in the relevant direction.
231230add_unclipped CropRight {cropped_image, output_width} = do
@@ -242,9 +241,9 @@ add_unclipped CropTop {cropped_image, top_skip} = do
242241 add_maybe_clipped cropped_image
243242
244243-- TODO: prove this cannot be called in an out of bounds case.
245−add_maybe_clipped :: Image -> BlitM s ()
244+add_maybe_clipped :: forall s . Image -> BlitM s ()
246245add_maybe_clipped EmptyImage = return ()
247−add_maybe_clipped (HorizText text_str ow _cw) = do
246+add_maybe_clipped (HorizText a text_str ow _cw) = do
248247 -- TODO: assumption that text spans are only 1 row high.
249248 s <- use skip_rows
250249 when (s < 1) $ do
@@ -254,7 +253,7 @@ add_maybe_clipped (HorizText text_str ow _cw) = do
254253 let left_clipped = left_clip > 0
255254 right_clipped = (ow - left_clip) > right_clip
256255 if left_clipped || right_clipped
257− then let text_str' = clip_text left_clip right_clip
256+ then let text_str' = clip_text text_str left_clip right_clip
258257 in add_unclipped_text text_str'
259258 else add_unclipped_text text_str
260259add_maybe_clipped (VertJoin top_image bottom_image _ow oh) = do
@@ -264,15 +263,15 @@ add_maybe_clipped (VertJoin top_image bottom_image _ow oh) = do
264263 bottom_image
265264 oh
266265add_maybe_clipped (HorizJoin left_image right_image ow _oh) = do
267− add_maybe_clipped_join "horiz_join" skip_columns remaining_columns devoid
266+ add_maybe_clipped_join "horiz_join" skip_columns remaining_columns column_offset
268267 (image_width right_image)
269268 left_image
270269 right_image
271270 ow
272271add_maybe_clipped BGFill {output_width, output_height} = do
273272 s <- get
274− let output_width' = min (output_width - s.^skip_columns) s.^remaining_columns
275− output_height' = min (output_height - s.^skip_rows ) s.^remaining_rows
273+ let output_width' = min (output_width - s^.skip_columns) (s^.remaining_columns)
274+ output_height' = min (output_height - s^.skip_rows ) (s^.remaining_rows)
276275 add_unclipped (BGFill output_width' output_height')
277276add_maybe_clipped CropRight {cropped_image, output_width} = do
278277 remaining_columns .= output_width
@@ -287,6 +286,15 @@ add_maybe_clipped CropTop {cropped_image, top_skip} = do
287286 skip_rows += top_skip
288287 add_maybe_clipped cropped_image
289288
289+add_maybe_clipped_join :: forall s . String
290+ -> Lens BlitState BlitState Int Int
291+ -> Lens BlitState BlitState Int Int
292+ -> Lens BlitState BlitState Int Int
293+ -> Int
294+ -> Image
295+ -> Image
296+ -> Int
297+ -> BlitM s ()
290298add_maybe_clipped_join name skip remaining offset i0_dim i0 i1 size = do
291299 state <- get
292300 when (state^.remaining == 0) $ fail $ name ++ " with remaining == 0"
@@ -313,7 +321,7 @@ add_maybe_clipped_join name skip remaining offset i0_dim i0 i1 size = do
313321-- TODO: represent display strings containing chars that are not 1 column chars as a separate
314322-- display string value?
315323-- TODO: assumes max column width is 2
316−clip_text :: DisplayString -> Int -> Int -> DisplayString
324+clip_text :: DisplayText -> Int -> Int -> DisplayText
317325clip_text txt left_skip right_clip =
318326 -- CPS would clarify this I think
319327 let (to_drop,pad_prefix) = clip_for_char_width left_skip txt 0
@@ -324,21 +332,38 @@ clip_text txt left_skip right_clip =
324332 clip_for_char_width w t n
325333 | w < cw = (n, True)
326334 | w == cw = (n+1, False)
327− | w > cw = clip_for_char_width (w - cw) (TL.rest t) (n + 1)
335+ | w > cw = clip_for_char_width (w - cw) (TL.tail t) (n + 1)
328336 where cw = safe_wcwidth (TL.head t)
329337 in txt''
330338
331−add_unclipped_text :: DisplayString -> BlitM ()
339+add_unclipped_text :: DisplayText -> BlitM s ()
332340add_unclipped_text txt = do
333− let op = TextSpan used_display_columns (TL.length txt) (TL.encodeUtf8 txt)
341+ let op = TextSpan used_display_columns
342+ (fromIntegral $ TL.length txt)
343+ (T.encodeUtf8 $ TL.toStrict txt)
334344 used_display_columns = wcswidth $ TL.unpack txt
335345 use row_offset >>= snoc_op op
336346
347+-- todo: If there is no background pattern defined then skip to next line.
348+-- todo: assumes background character is 1 column
349+add_row_completion :: Int -> BlitM s ()
350+add_row_completion row = do
351+ all_row_ops <- view mrow_ops
352+ Background c a <- view bg
353+ display_region <- view region
354+ row_ops <- lift $ lift $ Vector.read all_row_ops row
355+ let end_x = span_ops_effected_columns row_ops
356+ when (end_x < region_width display_region) $ do
357+ let ow = region_width display_region - end_x
358+ op = TextSpan ow ow (T.encodeUtf8 $ T.replicate (fromIntegral ow) (T.singleton c))
359+ snoc_op (AttributeChange a) row
360+ snoc_op op row
361+
337362-- | snocs the operation to the operations for the given row.
338363snoc_op :: SpanOp -> Int -> BlitM s ()
339364snoc_op !op !row = do
340365 the_mrow_ops <- view mrow_ops
341− lift $ do
366+ lift $ lift $ do
342367 ops <- Vector.read the_mrow_ops row
343368 let ops' = Vector.snoc ops op
344369 Vector.write the_mrow_ops row ops'