@@ -21,7 +21,7 @@ import Control.Monad.ST.Strict hiding ( unsafeIOToST )
2121
2222import qualified Data.Vector as Vector hiding ( take, replicate )
2323import Data.Vector.Mutable ( MVector(..))
24−import qualified Data.Vector.Mutable as Vector
24+import qualified Data.Vector.Mutable as MVector
2525
2626import qualified Data.Text as T
2727import qualified Data.Text.Encoding as T
@@ -51,8 +51,7 @@ data BlitState = BlitState
5151makeLenses ''BlitState
5252
5353data BlitEnv s = BlitEnv
54− { _bg :: Background
55− , _region :: DisplayRegion
54+ { _region :: DisplayRegion
5655 , _mrow_ops :: MRowOps s
5756 }
5857
@@ -70,22 +69,74 @@ spans_for_pic pic r = DisplayOps r $ Vector.create (combined_spans_for_layers pi
7069-- TODO: a fold over a builder function. start with span ops that are a bg fill of the entire
7170-- region.
7271combined_spans_for_layers :: Picture -> DisplayRegion -> ST s (MRowOps s)
73−combined_spans_for_layers pic r = do
74− layer_ops <- mapM (\layer -> build_spans layer r (pic_background pic)) (pic_layers pic)
75− case layer_ops of
76− [] -> fail "empty picture"
77− [ops] -> return ops
78− _ -> fail "TODO: picture with more than one layer not supported"
72+combined_spans_for_layers pic r
73+ | region_width r == 0 || region_height r == 0 = MVector.new 0
74+ | otherwise = do
75+ layer_ops <- mapM (\layer -> build_spans layer r) (pic_layers pic)
76+ case layer_ops of
77+ [] -> fail "empty picture"
78+ [ops] -> substitute_skips (pic_background pic) ops
79+ _ -> fail "TODO: picture with more than one layer not supported"
80+
81+substitute_skips :: Background -> MRowOps s -> ST s (MRowOps s)
82+substitute_skips ClearBackground ops = do
83+ forM_ [0 .. MVector.length ops - 1] $ \row -> do
84+ row_ops <- MVector.read ops row
85+ -- the image operations assure that background fills are combined.
86+ -- clipping a background fill does not split the background fill.
87+ -- merging of image layers can split a skip, but only by the insertion of a non skip.
88+ -- all this combines to mean we can check the last operation and remove it if it's a skip
89+ -- todo: or does it?
90+ let row_ops' = case Vector.last row_ops of
91+ Skip w -> Vector.init row_ops `Vector.snoc` RowEnd w
92+ _ -> row_ops
93+ -- now all the skips can be replaced by replications of ' ' of the required width.
94+ let row_ops'' = swap_skips_for_single_column_char_span ' ' row_ops'
95+ MVector.write ops row row_ops''
96+ return ops
97+substitute_skips (Background {background_char, background_attr}) ops = do
98+ -- At this point we decide if the background character is single column or not.
99+ -- obviously, single column is easier.
100+ case safe_wcwidth background_char of
101+ w | w == 0 -> fail $ "invalid background character " ++ show background_char
102+ | w == 1 -> do
103+ forM_ [0 .. MVector.length ops - 1] $ \row -> do
104+ row_ops <- MVector.read ops row
105+ let row_ops' = swap_skips_for_single_column_char_span background_char row_ops
106+ row_ops'' = (AttributeChange background_attr) `Vector.cons` row_ops'
107+ MVector.write ops row row_ops''
108+ | otherwise -> do
109+ forM_ [0 .. MVector.length ops - 1] $ \row -> do
110+ row_ops <- MVector.read ops row
111+ let row_ops' = swap_skips_for_char_span w background_char row_ops
112+ row_ops'' = (AttributeChange background_attr) `Vector.cons` row_ops'
113+ MVector.write ops row row_ops''
114+ return ops
115+
116+swap_skips_for_single_column_char_span :: Char -> SpanOps -> SpanOps
117+swap_skips_for_single_column_char_span c = Vector.map f
118+ where f (Skip ow) = TextSpan ow ow (T.encodeUtf8 $ T.pack $ replicate ow c)
119+ f v = v
120+
121+swap_skips_for_char_span :: Int -> Char -> SpanOps -> SpanOps
122+swap_skips_for_char_span w c = Vector.map f
123+ where
124+ f (Skip ow) = let txt_0_cw = ow `div` w
125+ txt_0 = T.pack $ replicate txt_0_cw c
126+ txt_1_cw = ow `mod` w
127+ txt_1 = T.pack $ replicate txt_1_cw '…'
128+ in TextSpan ow (txt_0_cw + txt_1_cw) $ T.encodeUtf8 (txt_0 `T.append` txt_1)
129+ f v = v
79130
80131-- | Builds a vector of row operations that will output the given picture to the terminal.
81132--
82133-- Crops to the given display region.
83134--
84135-- TODO: I'm pretty sure there is an algorithm that does not require a mutable buffer.
85−build_spans :: Image -> DisplayRegion -> Background -> ST s (MRowOps s)
86−build_spans image out_region background = do
136+build_spans :: Image -> DisplayRegion -> ST s (MRowOps s)
137+build_spans image out_region = do
87138 -- First we create a mutable vector for each rows output operations.
88− out_ops <- Vector.replicate (region_height out_region) Vector.empty
139+ out_ops <- MVector.replicate (region_height out_region) Vector.empty
89140 -- \todo I think building the span operations in display order would provide better performance.
90141 -- However, I got stuck trying to implement an algorithm that did this. This will be considered
91142 -- as a possible future optimization.
@@ -103,9 +154,9 @@ build_spans image out_region background = do
103154 -- bounds is also provided. This is used to clip the span ops produced to the display.
104155 let full_build = do
105156 start_image_build image
106− -- Fill in any unspecified columns with the background pattern.
157+ -- Fill in any unspecified columns with a skip.
107158 forM_ [0 .. (region_height out_region - 1)] (add_row_completion out_region)
108− init_env = BlitEnv background out_region out_ops
159+ init_env = BlitEnv out_region out_ops
109160 init_state = BlitState 0 0 0 0 (region_width out_region) (region_height out_region)
110161 _ <- runStateT (runReaderT full_build init_env) init_state
111162 return ()
@@ -143,13 +194,10 @@ add_unclipped (VertJoin part_top part_bottom _ow _oh) = do
143194 add_unclipped part_top
144195 row_offset .= y + image_height part_top
145196 add_unclipped part_bottom
146− -- TODO: assumes background character is 1 column
147197add_unclipped (BGFill ow oh) = do
148− Background c a <- view bg
149198 y <- use row_offset
150− let op = TextSpan ow ow (T.encodeUtf8 $ T.replicate (fromIntegral ow) (T.singleton c))
199+ let op = Skip ow
151200 forM_ [y..y+oh-1] $ \row -> do
152− snoc_op (AttributeChange a) row
153201 snoc_op op row
154202-- TODO: we know it's clipped actually, the equations that are exposed that introduce a
155203-- Crop all assure the image exceeds the crop in the relevant direction.
@@ -271,26 +319,21 @@ add_unclipped_text txt = do
271319 used_display_columns = wcswidth $ TL.unpack txt
272320 use row_offset >>= snoc_op op
273321
274−-- todo: If there is no background pattern defined then skip to next line.
275−-- todo: assumes background character is 1 column
276322add_row_completion :: DisplayRegion -> Int -> BlitM s ()
277323add_row_completion display_region row = do
278324 all_row_ops <- view mrow_ops
279− Background c a <- view bg
280− row_ops <- lift $ lift $ Vector.read all_row_ops row
325+ row_ops <- lift $ lift $ MVector.read all_row_ops row
281326 let end_x = span_ops_effected_columns row_ops
282327 when (end_x < region_width display_region) $ do
283328 let ow = region_width display_region - end_x
284− op = TextSpan ow ow (T.encodeUtf8 $ T.replicate (fromIntegral ow) (T.singleton c))
285− snoc_op (AttributeChange a) row
286− snoc_op op row
329+ snoc_op (Skip ow) row
287330
288331-- | snocs the operation to the operations for the given row.
289332snoc_op :: SpanOp -> Int -> BlitM s ()
290333snoc_op !op !row = do
291334 the_mrow_ops <- view mrow_ops
292335 lift $ lift $ do
293− ops <- Vector.read the_mrow_ops row
336+ ops <- MVector.read the_mrow_ops row
294337 let ops' = Vector.snoc ops op
295− Vector.write the_mrow_ops row ops'
338+ MVector.write the_mrow_ops row ops'
296339