@@ -18,18 +18,19 @@ import Codec.Binary.UTF8.String ( encode )
1818import Control.Monad ( forM_ )
1919import Control.Monad.ST.Strict
2020
21−import Data.Array.ST
21+import Data.Vector (Vector)
22+import qualified Data.Vector as Vector hiding ( take, replicate )
23+import Data.Vector.Mutable ( MVector(..))
24+import qualified Data.Vector.Mutable as Vector
25+
2226import qualified Data.ByteString as B
2327import qualified Data.ByteString.Internal as BInt
2428import qualified Data.Foldable as Foldable
25−import Data.List
2629import qualified Data.String.UTF8 as UTF8
2730import Data.Word
2831
2932import Foreign.Storable ( pokeByteOff )
3033
31−import GHC.Arr
32−
3334{- | A picture is translated into a sequences of state changes and character spans.
3435 - State changes are currently limited to new attribute values. The attribute is applied to all
3536 - following spans. Including spans of the next row. The nth element of the sequence represents the
@@ -37,39 +38,45 @@ import GHC.Arr
3738 -
3839 - A span op sequence will be defined for all rows and columns (and no more) of the region provided
3940 - with the picture to spans_for_pic.
40− -
4141 -
4242 - todo: Partition attribute changes into multiple categories according to the serialized
4343 - representation of the various attributes.
4444 -}
45−data SpanOpSequence = SpanOpSequence
46− { effected_region :: DisplayRegion
47− , row_ops :: RowOps
48− }
4945
50−type RowOps = Array Word SpanOps
51−type SpanOps = [SpanOp]
46+data DisplayOps = DisplayOps
47+ { effected_region :: DisplayRegion
48+ , display_ops :: RowOps
49+ }
50+
51+-- vector of span operation vectors. One per row of the screen.
52+type RowOps = Vector SpanOps
53+
54+type MRowOps s = MVector s SpanOps
5255
53−instance Show SpanOpSequence where
54− show (SpanOpSequence _ the_row_ops)
55− = concat $ ["{ "] ++ map (\ops -> show ops ++ "; " ) (elems the_row_ops) ++ [" }"]
56+-- vector of span operations. executed in succession
57+type SpanOps = Vector SpanOp
58+
59+type MSpanOps s = MVector s SpanOp
60+
61+instance Show DisplayOps where
62+ show (DisplayOps _ the_row_ops)
63+ = "{ " ++ (show $ Vector.map (\ops -> show ops ++ "; " ) the_row_ops) ++ " }"
5664
5765instance Show SpanOp where
5866 show (AttributeChange attr) = show attr
5967 show (TextSpan ow cw _) = "TextSpan " ++ show ow ++ " " ++ show cw
6068
61−span_ops_columns :: SpanOpSequence -> Word
69+span_ops_columns :: DisplayOps -> Word
6270span_ops_columns ops = region_width $ effected_region ops
6371
64−span_ops_rows :: SpanOpSequence -> Word
72+span_ops_rows :: DisplayOps -> Word
6573span_ops_rows ops = region_height $ effected_region ops
6674
67−span_ops_effected_columns :: [SpanOp] -> Word
68−span_ops_effected_columns in_ops = span_ops_effected_columns' 0 in_ops
75+span_ops_effected_columns :: SpanOps -> Word
76+span_ops_effected_columns in_ops = Vector.foldl' span_ops_effected_columns' 0 in_ops
6977 where
70− span_ops_effected_columns' t [] = t
71− span_ops_effected_columns' t (TextSpan w _ _ : r) = span_ops_effected_columns' (t + w) r
72− span_ops_effected_columns' t (_ : r) = span_ops_effected_columns' t r
78+ span_ops_effected_columns' t (TextSpan w _ _ ) = t + w
79+ span_ops_effected_columns' t _ = t
7380
7481-- |
7582--
@@ -84,54 +91,70 @@ data SpanOp =
8491 | TextSpan !Word !Word (UTF8.UTF8 B.ByteString)
8592 deriving Eq
8693
94+-- used to determine the width of a span operation , if it has one.
8795span_op_has_width :: SpanOp -> Maybe (Word, Word)
8896span_op_has_width (TextSpan ow cw _) = Just (cw, ow)
8997span_op_has_width _ = Nothing
9098
99+-- returns the number of columns to the character at the given position in the span op
91100columns_to_char_offset :: Word -> SpanOp -> Word
92101columns_to_char_offset cx (TextSpan _ _ utf8_str) =
93102 let str = UTF8.toString utf8_str
94− in toEnum $ sum $ map wcwidth $ take (fromEnum cx) str
103+ in toEnum $! sum $! map wcwidth $! take (fromEnum cx) str
95104columns_to_char_offset _cx _ = error "columns_to_char_offset applied to span op without width"
96105
97106-- | Produces the span ops that will render the given picture, possibly cropped or padded, into the
98107-- specified region.
99−spans_for_pic :: Picture -> DisplayRegion -> SpanOpSequence
100−spans_for_pic pic r = SpanOpSequence r $ runSTArray (build_spans pic r)
108+spans_for_pic :: Picture -> DisplayRegion -> DisplayOps
109+spans_for_pic pic r = DisplayOps r $ Vector.create (build_spans pic r)
101110
102−build_spans :: Picture -> DisplayRegion -> ST s (STArray s Word [SpanOp])
111+build_spans :: Picture -> DisplayRegion -> ST s (MRowOps s)
103112build_spans pic region = do
104− -- m for mutable
105− mrow_ops <- newSTArray (0, region_height region - 1) []
106− -- I think this can be better optimized if the build produced span operations in display order.
113+ -- m for mutable! ;-)
114+ mrow_ops <- Vector.replicate (fromEnum $ region_height region) Vector.empty
115+ -- XXX: I think building the span operations in display order would provide better performance.
107116 -- However, I got stuck trying to implement an algorithm that did this. This will be considered
108117 -- as a possible future optimization.
109118 --
110− -- A depth first traversal of the image is performed.
111− -- ordered according to the column range defined by the image from least to greatest.
112− -- The output row ops will at least have the region of the image specified. Iterate over all
113− -- output rows and output background fills for all unspecified columns.
119+ -- A depth first traversal of the image is performed. ordered according to the column range
120+ -- defined by the image from least to greatest. The output row ops will at least have the
121+ -- region of the image specified. Iterate over all output rows and output background fills for
122+ -- all unspecified columns.
123+ --
124+ -- The images are made into span operations from left to right. It's possible that this could
125+ -- easily be made to assure top to bottom output as well.
114126 if region_height region > 0
115127 then do
116128 -- The ops builder recursively descends the image and outputs span ops that would
117129 -- display that image. The number of columns remaining in this row before exceeding the
118− -- bounds is also provided. This is used to clip the span ops produced.
119− _ <- ops_for_row mrow_ops (pic_background pic) region (pic_image pic) (0,0) 0 (region_width region)
130+ -- bounds is also provided. This is used to clip the span ops produced to the display.
131+ -- The skip dimensions provided do....???
132+ _ <- row_ops_for_image mrow_ops
133+ (pic_image pic)
134+ (pic_background pic)
135+ region
136+ (0,0)
137+ 0
138+ (region_width region)
120139 -- Fill in any unspecified columns with the background pattern.
121− forM_ [0 .. region_height region - 1] $ \row -> do
122− end_x <- readSTArray mrow_ops row >>= return . span_ops_effected_columns
140+ forM_ [0 .. (fromEnum $ region_height region - 1)] $! \row -> do
141+ end_x <- Vector.read mrow_ops row >>= return . span_ops_effected_columns
123142 if end_x < region_width region
124143 then snoc_bg_fill mrow_ops (pic_background pic) (region_width region - end_x) row
125144 else return ()
126145 else return ()
127146 return mrow_ops
128147
129−type MRowOps s = STArray s Word SpanOps
130−
131−ops_for_row :: MRowOps s -> Background -> DisplayRegion -> Image -> (Word, Word) -> Word -> Word -> ST s (Word, Word)
132−ops_for_row mrow_ops bg region image skip_dim@(skip_row,skip_col) y remaining_columns
148+row_ops_for_image :: MRowOps s -> Image -> Background -> DisplayRegion -> (Word, Word) -> Int -> Word -> ST s (Word, Word)
149+row_ops_for_image mrow_ops -- the image to output the ops to
150+ image -- the image to rasterize in column order to mrow_ops
151+ bg -- the background fill
152+ region -- ???
153+ skip_dim@(skip_row,skip_col) -- the number of rows
154+ y -- ???
155+ remaining_columns -- ???
133156 | remaining_columns == 0 = return skip_dim
134− | y >= region_height region = return skip_dim
157+ | y >= fromEnum (region_height region) = return skip_dim
135158 | otherwise = case image of
136159 EmptyImage -> return skip_dim
137160 -- The width provided is the number of columns this text span will occupy when displayed.
@@ -143,22 +166,34 @@ ops_for_row mrow_ops bg region image skip_dim@(skip_row,skip_col) y remaining_co
143166 else do
144167 skip_col' <- snoc_text_span a text_str mrow_ops skip_col y remaining_columns
145168 return (skip_row, skip_col')
146− VertJoin t b _ _ -> do
147− (skip_row',skip_col') <- ops_for_row mrow_ops bg region t skip_dim y remaining_columns
148− (skip_row'',skip_col'') <- ops_for_row mrow_ops bg region b (skip_row', skip_col) (y + image_height t - (skip_row - skip_row')) remaining_columns
169+ VertJoin top_image bottom_image _ _ -> do
170+ (skip_row',skip_col') <- row_ops_for_image mrow_ops
171+ top_image
172+ bg
173+ region
174+ skip_dim
175+ y
176+ remaining_columns
177+ (skip_row'',skip_col'') <- row_ops_for_image mrow_ops
178+ bottom_image
179+ bg
180+ region
181+ (skip_row', skip_col)
182+ (y + (fromEnum $! image_height top_image) - (fromEnum $! skip_row - skip_row'))
183+ remaining_columns
149184 return (skip_row'', min skip_col' skip_col'')
150185 HorizJoin l r _ _ -> do
151− (skip_row',skip_col') <- ops_for_row mrow_ops bg region l skip_dim y remaining_columns
186+ (skip_row',skip_col') <- row_ops_for_image mrow_ops l bg region skip_dim y remaining_columns
152187 -- Don't output the right part unless there is at least a single column left after
153188 -- outputting the left part.
154189 if image_width l - (skip_col - skip_col') > remaining_columns
155190 then return (skip_row,skip_col')
156191 else do
157− (skip_row'',skip_col'') <- ops_for_row mrow_ops bg region r (skip_row, skip_col') y (remaining_columns - image_width l + (skip_col - skip_col'))
192+ (skip_row'',skip_col'') <- row_ops_for_image mrow_ops r bg region (skip_row, skip_col') y (remaining_columns - image_width l + (skip_col - skip_col'))
158193 return (min skip_row' skip_row'', skip_col'')
159194 BGFill width height -> do
160− let min_height = if y + height > region_height region
161− then region_height region - y
195+ let min_height = if y + (fromEnum height) > (fromEnum $! region_height region)
196+ then region_height region - (toEnum y)
162197 else height
163198 min_width = if width > remaining_columns
164199 then remaining_columns
@@ -169,7 +204,7 @@ ops_for_row mrow_ops bg region image skip_dim@(skip_row,skip_col) y remaining_co
169204 actual_width = if skip_col > min_width
170205 then 0
171206 else min_width - skip_col
172− forM_ [y .. y + actual_height - 1] $ \y' -> snoc_bg_fill mrow_ops bg actual_width y'
207+ forM_ [y .. y + fromEnum actual_height - 1] $! \y' -> snoc_bg_fill mrow_ops bg actual_width y'
173208 let skip_row' = if actual_height > skip_row
174209 then 0
175210 else skip_row - min_height
@@ -181,25 +216,25 @@ ops_for_row mrow_ops bg region image skip_dim@(skip_row,skip_col) y remaining_co
181216 if dx < 0
182217 -- Translation left
183218 -- Extract the delta and add it to skip_col.
184− then ops_for_row mrow_ops bg region (translate (0, dy) i) (skip_row, skip_col + dw) y remaining_columns
219+ then row_ops_for_image mrow_ops (translate (0, dy) i) bg region (skip_row, skip_col + dw) y remaining_columns
185220 -- Translation right
186221 else if dy < 0
187222 -- Translation up
188223 -- Extract the delta and add it to skip_row.
189− then ops_for_row mrow_ops bg region (translate (dx, 0) i) (skip_row + dh, skip_col) y remaining_columns
224+ then row_ops_for_image mrow_ops (translate (dx, 0) i) bg region (skip_row + dh, skip_col) y remaining_columns
190225 -- Translation down
191226 -- Pad the start of lines and above the image with a
192227 -- background_fill image.
193− else ops_for_row mrow_ops bg region (background_fill ow dh <-> (background_fill dw ih <|> i)) skip_dim y remaining_columns
228+ else row_ops_for_image mrow_ops (background_fill ow dh <-> (background_fill dw ih <|> i)) bg region skip_dim y remaining_columns
194229 where
195230 dw = toEnum $ abs dx
196231 dh = toEnum $ abs dy
197232 ow = image_width image
198233 ih = image_height i
199234 ImageCrop (max_w,max_h) i ->
200− if y >= max_h
235+ if y >= fromEnum max_h
201236 then return skip_dim
202− else ops_for_row mrow_ops bg region i skip_dim y (min remaining_columns max_w)
237+ else row_ops_for_image mrow_ops i bg region skip_dim y (min remaining_columns max_w)
203238 ImagePad (min_w,min_h) i -> do
204239 let hpad = if image_width i < min_w
205240 then background_fill (min_w - image_width i) (image_height i)
@@ -207,41 +242,68 @@ ops_for_row mrow_ops bg region image skip_dim@(skip_row,skip_col) y remaining_co
207242 let vpad = if image_height i < min_h
208243 then background_fill (image_width i) (min_h - image_height i)
209244 else empty_image
210− ops_for_row mrow_ops bg region ((i <|> hpad) <-> vpad) skip_dim y remaining_columns
245+ row_ops_for_image mrow_ops ((i <|> hpad) <-> vpad) bg region skip_dim y remaining_columns
211246
212−snoc_text_span :: Attr
213− -> DisplayString
214− -> MRowOps s
215− -> Word
216− -> Word
217− -> Word
247+snoc_text_span :: Attr -- the display attributes of the text span
248+ -> DisplayString -- the text to output
249+ -> MRowOps s -- the display operations to add to
250+ -> Word -- the number of display columns in the text span to
251+ -- skip before outputting
252+ -> Int -- the row of the display operations to add to
253+ -> Word -- the number of columns from the next column to be
254+ -- defined to the end of the display for the row.
218255 -> ST s Word
219−snoc_text_span a text_str mrow_ops skip_col y remaining_columns = do
256+snoc_text_span a text_str mrow_ops columns_to_skip y remaining_columns = do
220257 snoc_op mrow_ops y $ AttributeChange a
221− let (ow', dw', cw', txt) = Foldable.foldl'
222− build_text_span
223− ( 0, 0, 0, B.empty )
224− text_str
225− snoc_op mrow_ops y $ TextSpan ow' cw' (UTF8.fromRep txt)
226− return $ skip_col - dw'
258+ -- At most a text span will consist of remaining_columns characters
259+ -- we keep track of the position of the next character.
260+ let max_len :: Int = fromEnum remaining_columns
261+ mspan_chars <- Vector.new max_len
262+ ( used_display_columns, display_columns_skipped, used_char_count )
263+ <- Foldable.foldlM (build_text_span mspan_chars) ( 0, 0, 0 ) text_str
264+ -- once all characters have been output to mspan_chars we grab the used head
265+ out_text <- Vector.unsafeFreeze $! Vector.take used_char_count mspan_chars
266+ -- convert to UTF8 bytestring.
267+ -- This could be made faster. Hopefully the optimizer does a fair job at fusing the fold
268+ -- contained in fromString with the unfold in toList. No biggy right now then.
269+ snoc_op mrow_ops y $! TextSpan used_display_columns (toEnum used_char_count)
270+ $! UTF8.fromString
271+ $! Vector.toList out_text
272+ return $ columns_to_skip - display_columns_skipped
227273 where
228− build_text_span (ow', dw', char_count', b0) (c,w) = {-# SCC "build_text_span" #-}
229− if dw' == skip_col
230− then if ow' == remaining_columns
231− then ( ow', dw', char_count', b0 )
232− else if (w + ow') > remaining_columns
233− then ( remaining_columns, dw', char_count' + ooverflow, B.append b0 oelipses )
234− else ( ow' + w, dw', char_count' + 1, B.append b0 $ B.pack $ encode [c] )
235− else if (w + dw') > skip_col
236− then ( doverflow, skip_col, doverflow, B.append b0 delipses )
237− else ( ow', w + dw', char_count', b0 )
238− where
239− doverflow = skip_col - dw'
240− delipses = B.pack $ encode $ genericReplicate doverflow '…'
241− ooverflow = remaining_columns - ow'
242− oelipses = B.pack $ encode $ genericReplicate ooverflow '…'
274+ build_text_span mspan_chars (used_display_columns, display_columns_skipped, used_char_count)
275+ (out_char, char_display_width) = {-# SCC "build_text_span" #-}
276+ -- Only valid if the maximum width of a character is 2 display columns.
277+ -- XXX: Optimize into a skip pass then clipped fill pass
278+ if display_columns_skipped == columns_to_skip
279+ then if used_display_columns == remaining_columns
280+ then return $! ( used_display_columns, display_columns_skipped, used_char_count )
281+ else if ( used_display_columns + char_display_width ) > remaining_columns
282+ then do
283+ Vector.write mspan_chars used_char_count '…'
284+ return $! ( used_display_columns
285+ , display_columns_skipped
286+ , used_char_count + 1
287+ )
288+ else do
289+ Vector.write mspan_chars used_char_count out_char
290+ return $! ( used_display_columns + char_display_width
291+ , display_columns_skipped
292+ , used_char_count + 1
293+ )
294+ else if (display_columns_skipped + char_display_width) > columns_to_skip
295+ then do
296+ Vector.write mspan_chars used_char_count '…'
297+ return $! ( used_display_columns + 1
298+ , columns_to_skip
299+ , used_char_count + 1
300+ )
301+ else return $ ( used_display_columns
302+ , display_columns_skipped + char_display_width
303+ , used_char_count
304+ )
243305
244−snoc_bg_fill :: MRowOps s -> Background -> Word -> Word -> ST s ()
306+snoc_bg_fill :: MRowOps s -> Background -> Word -> Int -> ST s ()
245307snoc_bg_fill _row_ops _bg 0 _row
246308 = return ()
247309snoc_bg_fill mrow_ops (Background c back_attr) fill_length row
@@ -264,10 +326,9 @@ snoc_bg_fill mrow_ops (Background c back_attr) fill_length row
264326 $ zip [0 .. fromEnum (fill_length - 1)] (cycle c_bytes)
265327 snoc_op mrow_ops row $ TextSpan fill_length fill_length (UTF8.fromRep utf8_bs)
266328
267−snoc_op :: MRowOps s -> Word -> SpanOp -> ST s ()
329+snoc_op :: MRowOps s -> Int -> SpanOp -> ST s ()
268330snoc_op !mrow_ops !row !op = do
269− ops <- readSTArray mrow_ops row
270− let ops' = ops ++ [op]
271− writeSTArray mrow_ops row ops'
272− return ()
331+ ops <- Vector.read mrow_ops row
332+ let ops' = Vector.snoc ops op
333+ Vector.write mrow_ops row ops'
273334