diff --git a/src/Codec/Binary/UTF8/Width.hs b/src/Codec/Binary/UTF8/Width.hs deleted file mode 100644 index f9da2ca..0000000 --- a/src/Codec/Binary/UTF8/Width.hs +++ /dev/null @@ -1,33 +0,0 @@ --- Copyright 2009 Corey O'Connor -{-# OPTIONS_GHC -D_XOPEN_SOURCE -fno-cse #-} -{-# LANGUAGE ForeignFunctionInterface, BangPatterns #-} -module Codec.Binary.UTF8.Width ( wcwidth - , wcswidth - ) - where - -import Foreign.C.Types -import Foreign.C.String -import Foreign.Storable -import Foreign.Ptr - -import System.IO.Unsafe - -wcwidth :: Char -> Int -wcwidth c = unsafePerformIO (withCWString [c] $! \ws -> do - wc <- peek ws - let !w = fromIntegral $! wcwidth' wc - return w - ) -{-# NOINLINE wcwidth #-} - -foreign import ccall unsafe "vty_mk_wcwidth" wcwidth' :: CWchar -> CInt - -wcswidth :: String -> Int -wcswidth str = unsafePerformIO (withCWStringLen str $! \(ws, ws_len) -> do - let !w = fromIntegral $! wcswidth' ws (fromIntegral ws_len) - return w - ) -{-# NOINLINE wcswidth #-} - -foreign import ccall unsafe "vty_mk_wcswidth" wcswidth' :: Ptr CWchar -> CSize -> CInt diff --git a/src/Graphics/Text/Width.hs b/src/Graphics/Text/Width.hs new file mode 100644 index 0000000..054ee96 --- /dev/null +++ b/src/Graphics/Text/Width.hs @@ -0,0 +1,34 @@ +-- Copyright 2009 Corey O'Connor +{-# OPTIONS_GHC -D_XOPEN_SOURCE #-} +{-# LANGUAGE ForeignFunctionInterface #-} +module Graphics.Text.Width ( wcwidth + , wcswidth + , safe_wcwidth + , safe_wcswidth + ) + where + +foreign import ccall unsafe "vty_mk_wcwidth" wcwidth :: Char -> Int + +wcswidth :: String -> Int +wcswidth = sum . map wcwidth + +-- XXX: Characters with unknown widths occupy 1 column? +-- +-- Not sure if this is actually correct. I presume there is a replacement character that is output +-- by the terminal instead of the character and this replacement character is 1 column wide. If this +-- is not true for all terminals then a per-terminal replacement character width needs to be +-- implemented. + +-- | Returns the display width of a character. Assumes all characters with unknown widths are 1 width +safe_wcwidth :: Char -> Int +safe_wcwidth c = case wcwidth c of + i | i < 0 -> 1 + | otherwise -> i + +-- | Returns the display width of a string. Assumes all characters with unknown widths are 1 width +safe_wcswidth :: String -> Int +safe_wcswidth str = case wcswidth str of + i | i < 0 -> 1 + | otherwise -> i + diff --git a/src/Graphics/Vty/Image.hs b/src/Graphics/Vty/Image.hs index d2e77ad..ac0ff47 100644 --- a/src/Graphics/Vty/Image.hs +++ b/src/Graphics/Vty/Image.hs @@ -2,294 +2,140 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE DisambiguateRecordFields #-} -{-# OPTIONS_GHC -funbox-strict-fields #-} -module Graphics.Vty.Image ( DisplayString - , Image(..) +module Graphics.Vty.Image ( DisplayText + , Image , image_width , image_height + , horiz_join , (<|>) + , vert_join , (<->) , horiz_cat , vert_cat , background_fill + , text + , strict_text , char , string , iso_10646_string , utf8_string , utf8_bytestring + , utf8_strict_bytestring , char_fill , empty_image - , translate , safe_wcwidth , safe_wcswidth , wcwidth , wcswidth , crop + , crop_right + , crop_left + , crop_bottom + , crop_top , pad + , resize + , translate -- | The possible display attributes used in constructing an `Image`. , module Graphics.Vty.Attributes ) where import Graphics.Vty.Attributes +import Graphics.Vty.Image.Internal +import Graphics.Text.Width -import Codec.Binary.UTF8.Width - -import Codec.Binary.UTF8.String ( decode ) - -import Control.DeepSeq - -import qualified Data.ByteString as BS -import Data.Monoid -import qualified Data.Sequence as Seq -import qualified Data.String.UTF8 as UTF8 +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TL import Data.Word infixr 5 <|> infixr 4 <-> --- | We pair each character with it's display length. This way we only compute the length once per --- character. --- * Though currently the width of some strings is still compute multiple times. -type DisplayString = Seq.Seq (Char, Word) - --- | An image in VTY defines: +-- | combines two images side by side -- --- * properties required to display the image. These are properties that effect the output image --- but are independent of position +-- Combines text chunks where possible. Assures output_width and output_height properties are not +-- violated. -- --- * A set of position-dependent text and attribute regions. The possible regions are: +-- The result image will have a width equal to the sum of the two images width. And the height will +-- equal the largest height of the two images. The area not defined in one image due to a height +-- missmatch will be filled with the background pattern. -- --- * a point. ( char ) +-- TODO: the bg fill is biased towards top to bottom languages(?) +horiz_join :: Image -> Image -> Image +horiz_join EmptyImage i = i +horiz_join i EmptyImage = i +horiz_join i_0@(HorizText a_0 t_0 w_0 cw_0) i_1@(HorizText a_1 t_1 w_1 cw_1) + | a_0 == a_1 = HorizText a_0 (TL.append t_0 t_1) (w_0 + w_1) (cw_0 + cw_1) + | otherwise = HorizJoin i_0 i_1 (w_0 + w_1) (image_height i_0 + image_height i_1) +horiz_join i_0 i_1 + -- If the images are of the same height then no padding is required + | h_0 == h_1 = HorizJoin i_0 i_1 w h_0 + -- otherwise one of the images needs to be padded to the right size. + | h_0 < h_1 -- Pad i_0 + = let pad_amount = h_1 - h_0 + in HorizJoin (VertJoin i_0 (BGFill w_0 pad_amount) w_0 h_1) i_1 w h_1 + | h_0 > h_1 -- Pad i_1 + = let pad_amount = h_0 - h_1 + in HorizJoin i_0 (VertJoin i_1 (BGFill w_1 pad_amount) w_1 h_0) w h_0 + where + w_0 = image_width i_0 + w_1 = image_width i_1 + w = w_0 + w_1 + h_0 = image_height i_0 + h_1 = image_height i_1 +horiz_join _ _ = error "horiz_join applied to undefined values." + +-- | combines two images vertically -- --- * a horizontal line of characters with a single attribute. (string, utf8_string, --- utf8_bytestring ) +-- The result image will have a height equal to the sum of the heights of both images. +-- The width will equal the largest width of the two images. +-- The area not defined in one image due to a width missmatch will be filled with the background +-- pattern. -- --- * a fill of a single character. (char_fill) --- --- * a fill of the picture's background. (background_fill) --- --- todo: increase the number of encoded bytestring formats supported. -data Image = - -- | A horizontal text span is always >= 1 column and has a row height of 1. - HorizText - { attr :: !Attr - -- All character data is stored as Char sequences with the ISO-10646 encoding. - , text :: DisplayString - , output_width :: !Word -- >= 0 - , char_width :: !Word -- >= 1 - } - -- | A horizontal join can be constructed between any two images. However a HorizJoin instance is - -- required to be between two images of equal height. The horiz_join constructor adds background - -- filles to the provided images that assure this is true for the HorizJoin value produced. - | HorizJoin - { part_left :: Image - , part_right :: Image - , output_width :: !Word -- >= 1 - , output_height :: !Word -- >= 1 - } - -- | A veritical join can be constructed between any two images. However a VertJoin instance is - -- required to be between two images of equal width. The vert_join constructor adds background - -- fills to the provides images that assure this is true for the VertJoin value produced. - | VertJoin - { part_top :: Image - , part_bottom :: Image - , output_width :: !Word -- >= 1 - , output_height :: !Word -- >= 1 - } - -- | A background fill will be filled with the background pattern. The background pattern is - -- defined as a property of the Picture this Image is used to form. - | BGFill - { output_width :: !Word -- >= 1 - , output_height :: !Word -- >= 1 - } - -- | The combining operators identity constant. - -- EmptyImage <|> a = a - -- EmptyImage <-> a = a - -- - -- Any image of zero size equals the empty image. - | EmptyImage - | Translation (Int, Int) Image - -- Crop an image to a size - | ImageCrop (Word, Word) Image - -- Pad an image up to a size - | ImagePad (Word, Word) Image - deriving Eq - -instance Show Image where - show ( HorizText { output_width = ow, text = txt } ) - = "HorizText [" ++ show ow ++ "] (" ++ show (fmap fst txt) ++ ")" - show ( BGFill { output_width = c, output_height = r } ) - = "BGFill (" ++ show c ++ "," ++ show r ++ ")" - show ( HorizJoin { part_left = l, part_right = r, output_width = c } ) - = "HorizJoin " ++ show c ++ " ( " ++ show l ++ " <|> " ++ show r ++ " )" - show ( VertJoin { part_top = t, part_bottom = b, output_width = c, output_height = r } ) - = "VertJoin (" ++ show c ++ ", " ++ show r ++ ") ( " ++ show t ++ " ) <-> ( " ++ show b ++ " )" - show ( Translation offset i ) - = "Translation " ++ show offset ++ " ( " ++ show i ++ " )" - show ( ImageCrop size i ) - = "ImageCrop " ++ show size ++ " ( " ++ show i ++ " )" - show ( ImagePad size i ) - = "ImagePad " ++ show size ++ " ( " ++ show i ++ " )" - show ( EmptyImage ) = "EmptyImage" - --- | Currently append in the Monoid instance is equivalent to <->. -instance Monoid Image where - mempty = empty_image - mappend = (<->) - -instance NFData Image where - rnf EmptyImage = () - rnf (Translation s i) = s `deepseq` i `deepseq` () - rnf (ImagePad s i) = s `deepseq` i `deepseq` () - rnf (ImageCrop s i) = s `deepseq` i `deepseq` () - rnf (BGFill !w !h) = () - rnf (VertJoin t b !w !h) = t `deepseq` b `deepseq` () - rnf (HorizJoin l r !w !h) = l `deepseq` r `deepseq` () - rnf (HorizText !a s !w !cw) = s `deepseq` () - --- A horizontal text image of 0 characters in width simplifies to the EmptyImage -horiz_text :: Attr -> DisplayString -> Word -> Image -horiz_text a txt ow - | ow == 0 = EmptyImage - | otherwise = HorizText a txt ow (toEnum $ Seq.length txt) - -horiz_join :: Image -> Image -> Word -> Word -> Image -horiz_join i_0 i_1 w h - -- A horiz join of two 0 width images simplifies to the EmptyImage - | w == 0 = EmptyImage - -- A horizontal join where either part is 0 columns in width simplifies to the other part. - -- This covers the case where one part is the EmptyImage. - | image_width i_0 == 0 = i_1 - | image_width i_1 == 0 = i_0 - -- If the images are of the same height then no BG padding is required - | image_height i_0 == image_height i_1 = HorizJoin i_0 i_1 w h - -- otherwise one of the imagess needs to be padded to the right size. - | image_height i_0 < image_height i_1 -- Pad i_0 - = let pad_amount = image_height i_1 - image_height i_0 - in horiz_join ( vert_join i_0 - ( BGFill ( image_width i_0 ) pad_amount ) - ( image_width i_0 ) - ( image_height i_1 ) - ) - i_1 - w h - | image_height i_0 > image_height i_1 -- Pad i_1 - = let pad_amount = image_height i_0 - image_height i_1 - in horiz_join i_0 - ( vert_join i_1 - ( BGFill ( image_width i_1 ) pad_amount ) - ( image_width i_1 ) - ( image_height i_0 ) - ) - w h -horiz_join _ _ _ _ = error "horiz_join applied to undefined values." - -vert_join :: Image -> Image -> Word -> Word -> Image -vert_join i_0 i_1 w h - -- A vertical join of two 0 height images simplifies to the EmptyImage - | h == 0 = EmptyImage - -- A vertical join where either part is 0 rows in height simplifies to the other part. - -- This covers the case where one part is the EmptyImage - | image_height i_0 == 0 = i_1 - | image_height i_1 == 0 = i_0 +-- TODO: the bg fill is biased towards right to left languages(?) +vert_join :: Image -> Image -> Image +vert_join EmptyImage i = i +vert_join i EmptyImage = i +vert_join i_0 i_1 -- If the images are of the same height then no background padding is required - | image_width i_0 == image_width i_1 = VertJoin i_0 i_1 w h + | w_0 == w_1 = VertJoin i_0 i_1 w_0 h -- Otherwise one of the images needs to be padded to the size of the other image. - | image_width i_0 < image_width i_1 - = let pad_amount = image_width i_1 - image_width i_0 - in vert_join ( horiz_join i_0 - ( BGFill pad_amount ( image_height i_0 ) ) - ( image_width i_1 ) - ( image_height i_0 ) - ) - i_1 - w h - | image_width i_0 > image_width i_1 - = let pad_amount = image_width i_0 - image_width i_1 - in vert_join i_0 - ( horiz_join i_1 - ( BGFill pad_amount ( image_height i_1 ) ) - ( image_width i_0 ) - ( image_height i_1 ) - ) - w h -vert_join _ _ _ _ = error "vert_join applied to undefined values." + | w_0 < w_1 + = let pad_amount = w_1 - w_0 + in VertJoin (HorizJoin i_0 (BGFill pad_amount h_0) w_1 h_0) i_1 w_1 h + | w_0 > w_1 + = let pad_amount = w_0 - w_1 + in VertJoin i_0 (HorizJoin i_1 (BGFill pad_amount h_1) w_0 h_1) w_0 h + where + w_0 = image_width i_0 + w_1 = image_width i_1 + h_0 = image_height i_0 + h_1 = image_height i_1 + h = h_0 + h_1 +vert_join _ _ = error "vert_join applied to undefined values." -- | An area of the picture's bacground (See Background) of w columns and h rows. -background_fill :: Word -> Word -> Image +background_fill :: Int -> Int -> Image background_fill w h | w == 0 = EmptyImage | h == 0 = EmptyImage | otherwise = BGFill w h --- | The width of an Image. This is the number display columns the image will occupy. -image_width :: Image -> Word -image_width HorizText { output_width = w } = w -image_width HorizJoin { output_width = w } = w -image_width VertJoin { output_width = w } = w -image_width BGFill { output_width = w } = w -image_width EmptyImage = 0 -image_width ( Translation v i ) = toEnum $ max 0 $ (fst v +) $ fromEnum $ image_width i -image_width ( ImageCrop v i ) = min (image_width i) $ fst v -image_width ( ImagePad v i ) = max (image_width i) $ fst v - --- | The height of an Image. This is the number of display rows the image will occupy. -image_height :: Image -> Word -image_height HorizText {} = 1 -image_height HorizJoin { output_height = r } = r -image_height VertJoin { output_height = r } = r -image_height BGFill { output_height = r } = r -image_height EmptyImage = 0 -image_height ( Translation v i ) = toEnum $ max 0 $ (snd v +) $ fromEnum $ image_height i -image_height ( ImageCrop v i ) = min (image_height i) $ snd v -image_height ( ImagePad v i ) = max (image_height i) $ snd v - --- | Combines two images side by side. +-- | Combines two images horizontally. Alias for horiz_join -- --- The result image will have a width equal to the sum of the two images width. And the height will --- equal the largest height of the two images. The area not defined in one image due to a height --- missmatch will be filled with the background pattern. +-- infixr 5 (<|>) :: Image -> Image -> Image +(<|>) = horiz_join --- Two horizontal text spans with the same attributes can be merged. -h0@(HorizText attr_0 text_0 ow_0 _) <|> h1@(HorizText attr_1 text_1 ow_1 _) - | attr_0 == attr_1 = horiz_text attr_0 (text_0 Seq.>< text_1) (ow_0 + ow_1) - | otherwise = horiz_join h0 h1 (ow_0 + ow_1) 1 - --- Anything placed to the right of a join wil be joined to the right sub image. --- The total columns for the join is the sum of the two arguments columns -h0@( HorizJoin {} ) <|> h1 - = horiz_join ( part_left h0 ) - ( part_right h0 <|> h1 ) - ( image_width h0 + image_width h1 ) - ( max (image_height h0) (image_height h1) ) - --- Anything but a join placed to the left of a join wil be joined to the left sub image. --- The total columns for the join is the sum of the two arguments columns -h0 <|> h1@( HorizJoin {} ) - = horiz_join ( h0 <|> part_left h1 ) - ( part_right h1 ) - ( image_width h0 + image_width h1 ) - ( max (image_height h0) (image_height h1) ) - -h0 <|> h1 - = horiz_join h0 - h1 - ( image_width h0 + image_width h1 ) - ( max (image_height h0) (image_height h1) ) - --- | Combines two images vertically. --- The result image will have a height equal to the sum of the heights of both images. --- The width will equal the largest width of the two images. --- The area not defined in one image due to a width missmatch will be filled with the background --- pattern. +-- | Combines two images vertically. Alias for vert_join +-- +-- infixr 4 (<->) :: Image -> Image -> Image -im_t <-> im_b - = vert_join im_t - im_b - ( max (image_width im_t) (image_width im_b) ) - ( image_height im_t + image_height im_b ) +(<->) = vert_join -- | Compose any number of images horizontally. horiz_cat :: [Image] -> Image @@ -299,12 +145,26 @@ horiz_cat = foldr (<|>) EmptyImage vert_cat :: [Image] -> Image vert_cat = foldr (<->) EmptyImage +-- | A Data.Text.Lazy value +text :: Attr -> TL.Text -> Image +text a txt + | TL.length txt == 0 = EmptyImage + | otherwise = let display_width = safe_wcswidth (TL.unpack txt) + in HorizText a txt display_width (fromIntegral $! TL.length txt) + +-- | A Data.Text value +strict_text :: Attr -> T.Text -> Image +strict_text a txt + | T.length txt == 0 = EmptyImage + | otherwise = let display_width = safe_wcswidth (T.unpack txt) + in HorizText a (TL.fromStrict txt) display_width (T.length txt) + -- | an image of a single character. This is a standard Haskell 31-bit character assumed to be in -- the ISO-10646 encoding. char :: Attr -> Char -> Image -char !a !c = +char a c = let display_width = safe_wcwidth c - in HorizText a (Seq.singleton (c, display_width)) display_width 1 + in HorizText a (TL.singleton c) display_width 1 -- | A string of characters layed out on a single row with the same display attribute. The string is -- assumed to be a sequence of ISO-10646 characters. @@ -316,9 +176,9 @@ char !a !c = -- directly to iso_10646_string or string. -- iso_10646_string :: Attr -> String -> Image -iso_10646_string !a !str = - let display_text = Seq.fromList $ map (\c -> (c, safe_wcwidth c)) str - in horiz_text a display_text (safe_wcswidth str) +iso_10646_string a str = + let display_width = safe_wcswidth str + in HorizText a (TL.pack str) display_width (length str) -- | Alias for iso_10646_string. Since the usual case is that a literal string like "foo" is -- represented internally as a list of ISO 10646 31 bit characters. @@ -329,62 +189,110 @@ iso_10646_string !a !str = string :: Attr -> String -> Image string = iso_10646_string --- | A string of characters layed out on a single row. The string is assumed to be a sequence of --- UTF-8 characters. +-- | A string of characters layed out on a single row. The input is assumed to be the bytes for +-- UTF-8 encoded text. utf8_string :: Attr -> [Word8] -> Image -utf8_string !a !str = string a ( decode str ) +utf8_string a bytes = utf8_bytestring a (BL.pack bytes) --- XXX: Characters with unknown widths occupy 1 column? --- --- Not sure if this is actually correct. I presume there is a replacement character that is output --- by the terminal instead of the character and this replacement character is 1 column wide. If this --- is not true for all terminals then a per-terminal replacement character width needs to be --- implemented. +-- | Renders a UTF-8 encoded lazy bytestring. +utf8_bytestring :: Attr -> BL.ByteString -> Image +utf8_bytestring a bs = text a (TL.decodeUtf8 bs) --- | Returns the display width of a character. Assumes all characters with unknown widths are 1 width -safe_wcwidth :: Char -> Word -safe_wcwidth c = case wcwidth c of - i | i < 0 -> 1 - | otherwise -> toEnum i - --- | Returns the display width of a string. Assumes all characters with unknown widths are 1 width -safe_wcswidth :: String -> Word -safe_wcswidth str = case wcswidth str of - i | i < 0 -> 1 - | otherwise -> toEnum i - --- | Renders a UTF-8 encoded bytestring. -utf8_bytestring :: Attr -> BS.ByteString -> Image -utf8_bytestring !a !bs = string a (UTF8.toString $ UTF8.fromRep bs) +-- | Renders a UTF-8 encoded strict bytestring. +utf8_strict_bytestring :: Attr -> B.ByteString -> Image +utf8_strict_bytestring a bs = strict_text a (T.decodeUtf8 bs) -- | creates a fill of the specified character. The dimensions are in number of characters wide and -- number of rows high. -- -- Unlike the Background fill character this character can have double column display width. -char_fill :: Enum d => Attr -> Char -> d -> d -> Image -char_fill !a !c w h = - vert_cat $ replicate (fromEnum h) $ horiz_cat $ replicate (fromEnum w) $ char a c +char_fill :: Integral d => Attr -> Char -> d -> d -> Image +char_fill _a _c 0 _h = EmptyImage +char_fill _a _c _w 0 = EmptyImage +char_fill a c w h = + vert_cat $ replicate (fromIntegral h) $ HorizText a txt display_width char_width + where + txt = TL.replicate (fromIntegral w) (TL.singleton c) + display_width = safe_wcwidth c * (fromIntegral w) + char_width = fromIntegral w -- | The empty image. Useful for fold combinators. These occupy no space nor define any display -- attributes. empty_image :: Image empty_image = EmptyImage --- | Apply the given offset to the image. -translate :: (Int, Int) -> Image -> Image -translate v i = Translation v i +-- | pad the given image. This adds background character fills to the left, top, right, bottom. +pad :: Int -> Int -> Int -> Int -> Image -> Image +pad 0 0 0 0 i = i +pad in_l in_t in_r in_b in_image + | in_l < 0 || in_t < 0 || in_r < 0 || in_b < 0 = error "cannot pad by negative amount" + | otherwise = go in_l in_t in_r in_b in_image + where + -- TODO: uh. + go 0 0 0 0 i = i + go 0 0 0 b i = VertJoin i (BGFill w b) w h + where w = image_width i + h = image_height i + b + go 0 0 r b i = go 0 0 0 b $ HorizJoin i (BGFill r h) w h + where w = image_width i + r + h = image_height i + go 0 t r b i = go 0 0 r b $ VertJoin (BGFill w t) i w h + where w = image_width i + h = image_height i + t + go l t r b i = go 0 t r b $ HorizJoin (BGFill l h) i w h + where w = image_width i + l + h = image_height i --- | Ensure an image is no larger than the provided size. If the image is larger then crop. -crop :: (Word, Word) -> Image -> Image -crop (0,_) _ = EmptyImage -crop (_,0) _ = EmptyImage -crop v (ImageCrop _size i) = ImageCrop (min (fst v) (fst _size), min (snd v) (snd _size)) i -crop v i = ImageCrop v i +-- | "translates" an image by padding the top and left. +translate :: Int -> Int -> Image -> Image +translate x y i = pad x y 0 0 i --- | Ensure an image is at least the provided size. If the image is smaller then pad. -pad :: (Word, Word) -> Image -> Image -pad (0,_) _ = EmptyImage -pad (_,0) _ = EmptyImage -pad v (ImagePad _size i) = ImagePad (max (fst v) (fst _size), max (snd v) (snd _size)) i -pad v i = ImagePad v i +-- | Ensure an image is no larger than the provided size. If the image is larger then crop the right +-- or bottom. +-- +-- This is transformed to a vertical crop from the bottom followed by horizontal crop from the +-- right. +crop :: Int -> Int -> Image -> Image +crop 0 _ _ = EmptyImage +crop _ 0 _ = EmptyImage +crop w h i = crop_bottom h (crop_right w i) + +-- | crop the display height. If the image is less than or equal in height then this operation has +-- no effect. Otherwise the image is cropped from the bottom. +crop_bottom :: Int -> Image -> Image +crop_bottom 0 _ = EmptyImage +crop_bottom h in_i + | h < 0 = error "cannot crop height to less than zero" + | otherwise = go in_i + where + go EmptyImage = EmptyImage + go (CropBottom {cropped_image, output_width, output_height}) = + CropBottom cropped_image output_width (min h output_height) + go i + | h >= image_height i = i + | otherwise = CropBottom i (image_width i) h + +crop_right :: Int -> Image -> Image +crop_right 0 _ = EmptyImage +crop_right w in_i + | w < 0 = error "cannot crop width to less than zero" + | otherwise = go in_i + where + go EmptyImage = EmptyImage + go (CropRight {cropped_image, output_width, output_height}) = + CropRight cropped_image (min w output_width) output_height + go i + | w >= image_width i = i + | otherwise = CropRight i w (image_height i) + +crop_left :: Int -> Image -> Image +crop_left _ _ = error "not implemented" + +crop_top :: Int -> Image -> Image +crop_top _ _ = error "not implemented" + +-- | Generic resize. Pads and crops as required to assure the given display width and height. +-- This is biased to pad the right and bottom. +resize :: Int -> Int -> Image -> Image +resize _w _h _i = error "not implemented yet" diff --git a/src/Graphics/Vty/Image/Internal.hs b/src/Graphics/Vty/Image/Internal.hs new file mode 100644 index 0000000..c4c8cd6 --- /dev/null +++ b/src/Graphics/Vty/Image/Internal.hs @@ -0,0 +1,162 @@ +{-# LANGUAGE NamedFieldPuns #-} +module Graphics.Vty.Image.Internal where + +import Graphics.Vty.Attributes + +import Control.DeepSeq + +import qualified Data.Text.Lazy as TL + +-- | A display text is a Data.Text.Lazy +-- +-- TODO(corey): hm. there is an explicit equation for each type which goes to a lazy text. Each +-- application probably uses a single type. Perhaps parameterize the entire vty interface by the +-- input text type? +type DisplayText = TL.Text + +-- | An image in VTY is +-- +-- * a horizontal line of characters with a single attribute. +-- * a fill of the picture's background. (background_fill) +-- * a horizontal and vertical crops from both directions. +-- * horizontal and vertical combinations +data Image = + -- | A horizontal text span is always >= 1 column and has a row height of 1. + HorizText + { attr :: Attr + -- | The text to display. The display width of the text is always output_width. + , display_text :: DisplayText + -- | The number of display columns for the text. + , output_width :: Int + -- | the number of characters in the text. + , char_width :: Int + } + -- | A horizontal join can be constructed between any two images. However a HorizJoin instance is + -- required to be between two images of equal height. The horiz_join constructor adds background + -- filles to the provided images that assure this is true for the HorizJoin value produced. + | HorizJoin + { part_left :: Image + , part_right :: Image + , output_width :: Int -- ^ image_width part_left == image_width part_right. Always > 1 + , output_height :: Int -- ^ image_height part_left == image_height part_right. Always > 0 + } + -- | A veritical join can be constructed between any two images. However a VertJoin instance is + -- required to be between two images of equal width. The vert_join constructor adds background + -- fills to the provides images that assure this is true for the VertJoin value produced. + | VertJoin + { part_top :: Image + , part_bottom :: Image + , output_width :: Int -- ^ image_width part_top == image_width part_bottom. always > 0 + , output_height :: Int -- ^ image_height part_top == image_height part_bottom. always > 1 + } + -- | A background fill will be filled with the background char. The background char is + -- defined as a property of the Picture this Image is used to form. + | BGFill + { output_width :: Int -- ^ always > 0 + , output_height :: Int -- ^ always > 0 + } + -- | Crop an image horizontally to a size by reducing the size from the right. + | CropRight + { cropped_image :: Image + -- | Always < image_width cropped_image > 0 + , output_width :: Int + , output_height :: Int -- ^ image_height cropped_image + } + -- | Crop an image horizontally to a size by reducing the size from the left. + | CropLeft + { cropped_image :: Image + -- | Always < image_width cropped_image > 0 + , left_skip :: Int + -- | Always < image_width cropped_image > 0 + , output_width :: Int + , output_height :: Int + } + -- | Crop an image vertically to a size by reducing the size from the bottom + | CropBottom + { cropped_image :: Image + -- | image_width cropped_image + , output_width :: Int + -- | height image is cropped to. Always < image_height cropped_image > 0 + , output_height :: Int + } + -- | Crop an image vertically to a size by reducing the size from the top + | CropTop + { cropped_image :: Image + -- | Always < image_height cropped_image > 0 + , top_skip :: Int + -- | image_width cropped_image + , output_width :: Int + -- | Always < image_height cropped_image > 0 + , output_height :: Int + } + -- | The empty image + -- + -- The combining operators identity constant. + -- EmptyImage <|> a = a + -- EmptyImage <-> a = a + -- + -- Any image of zero size equals the empty image. + | EmptyImage + deriving Eq + +instance Show Image where + show ( HorizText { attr, display_text, output_width, char_width } ) + = "HorizText \"" ++ show display_text ++ "\"" + ++ "@(" ++ show attr ++ "," + ++ show output_width ++ "," + ++ show char_width ++ ")" + show ( BGFill { output_width, output_height } ) + = "BGFill (" ++ show output_width ++ "," ++ show output_height ++ ")" + show ( HorizJoin { part_left = l, part_right = r, output_width = c } ) + = "HorizJoin " ++ show c ++ " (" ++ show l ++ " <|> " ++ show r ++ ")" + show ( VertJoin { part_top = t, part_bottom = b, output_width = c, output_height = r } ) + = "VertJoin [" ++ show c ++ ", " ++ show r ++ "] (" ++ show t ++ ") <-> (" ++ show b ++ ")" + show ( CropRight { cropped_image, output_width, output_height } ) + = "CropRight [" ++ show output_width ++ "," ++ show output_height ++ "]" + ++ " (" ++ show cropped_image ++ ")" + show ( CropLeft { cropped_image, left_skip, output_width, output_height } ) + = "CropLeft [" ++ show left_skip ++ "," ++ show output_width ++ "," ++ show output_height ++ "]" + ++ " (" ++ show cropped_image ++ ")" + show ( CropBottom { cropped_image, output_width, output_height } ) + = "CropBottom [" ++ show output_width ++ "," ++ show output_height ++ "]" + ++ " (" ++ show cropped_image ++ ")" + show ( CropTop { cropped_image, top_skip, output_width, output_height } ) + = "CropTop [" ++ show top_skip ++ "," ++ show output_width ++ "," ++ show output_height ++ "]" + ++ " (" ++ show cropped_image ++ ")" + show ( EmptyImage ) = "EmptyImage" + +instance NFData Image where + rnf EmptyImage = () + rnf (CropRight i w h) = i `deepseq` w `seq` h `seq` () + rnf (CropLeft i s w h) = i `deepseq` s `seq` w `seq` h `seq` () + rnf (CropBottom i w h) = i `deepseq` w `seq` h `seq` () + rnf (CropTop i s w h) = i `deepseq` s `seq` w `seq` h `seq` () + rnf (BGFill w h) = w `seq` h `seq` () + rnf (VertJoin t b w h) = t `deepseq` b `deepseq` w `seq` h `seq` () + rnf (HorizJoin l r w h) = l `deepseq` r `deepseq` w `seq` h `seq` () + rnf (HorizText a s w cw) = a `seq` s `deepseq` w `seq` cw `seq` () + +-- | The width of an Image. This is the number display columns the image will occupy. +image_width :: Image -> Int +image_width HorizText { output_width = w } = w +image_width HorizJoin { output_width = w } = w +image_width VertJoin { output_width = w } = w +image_width BGFill { output_width = w } = w +image_width CropRight { output_width = w } = w +image_width CropLeft { output_width = w } = w +image_width CropBottom { output_width = w } = w +image_width CropTop { output_width = w } = w +image_width EmptyImage = 0 + +-- | The height of an Image. This is the number of display rows the image will occupy. +image_height :: Image -> Int +image_height HorizText {} = 1 +image_height HorizJoin { output_height = h } = h +image_height VertJoin { output_height = h } = h +image_height BGFill { output_height = h } = h +image_height CropRight { output_height = h } = h +image_height CropLeft { output_height = h } = h +image_height CropBottom { output_height = h } = h +image_height CropTop { output_height = h } = h +image_height EmptyImage = 0 + diff --git a/src/Graphics/Vty/Picture.hs b/src/Graphics/Vty/Picture.hs index 9bac58e..6a0fb49 100644 --- a/src/Graphics/Vty/Picture.hs +++ b/src/Graphics/Vty/Picture.hs @@ -83,8 +83,10 @@ instance NFData Cursor where -- screen to a picture. -- -- \todo The background character *must* occupy a single column and no more. +-- +-- \todo background char should be optional data Background = Background - { background_char :: Char + { background_char :: Char , background_attr :: Attr } diff --git a/src/Graphics/Vty/Span.hs b/src/Graphics/Vty/Span.hs index 208990c..dc258ec 100644 --- a/src/Graphics/Vty/Span.hs +++ b/src/Graphics/Vty/Span.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE TemplateHaskell #-} -- Copyright 2009-2010 Corey O'Connor {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ExistentialQuantification #-} @@ -10,28 +12,37 @@ module Graphics.Vty.Span where import Graphics.Vty.Image +import Graphics.Vty.Image.Internal import Graphics.Vty.Picture import Graphics.Vty.DisplayRegion +import Graphics.Text.Width -import Codec.Binary.UTF8.String ( encode ) - +import Control.Lens import Control.Monad ( forM_ ) +import Control.Monad.Reader.Strict +import Control.Monad.State.Strict import Control.Monad.ST.Strict hiding ( unsafeIOToST ) import Control.Monad.ST.Unsafe ( unsafeIOToST ) +import Data.Monoid import Data.Vector (Vector) import qualified Data.Vector as Vector hiding ( take, replicate ) import Data.Vector.Mutable ( MVector(..)) import qualified Data.Vector.Mutable as Vector -import qualified Data.ByteString as B -import qualified Data.ByteString.Internal as BInt +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Lazy.Internal as BLInt import qualified Data.Foldable as Foldable -import qualified Data.String.UTF8 as UTF8 +import qualified Data.Text.Lazy as TL import Data.Word import Foreign.Storable ( pokeByteOff ) +-- | Currently append in the Monoid instance is equivalent to <->. +instance Monoid Image where + mempty = EmptyImage + mappend = (<->) + {- | A picture is translated into a sequences of state changes and character spans. - State changes are currently limited to new attribute values. The attribute is applied to all - following spans. Including spans of the next row. The nth element of the sequence represents the @@ -96,19 +107,19 @@ data SpanOp = -- | a span of UTF-8 text occupies a specific number of screen space columns. A single UTF -- character does not necessarially represent 1 colunm. See Codec.Binary.UTF8.Width -- TextSpan [output width in columns] [number of characters] [data] - | TextSpan !Word !Word (UTF8.UTF8 B.ByteString) + | TextSpan !Int !Int BL.ByteString deriving Eq -- | The width of a single SpanOp in columns -span_op_has_width :: SpanOp -> Maybe (Word, Word) +span_op_has_width :: SpanOp -> Maybe (Int, Int) span_op_has_width (TextSpan ow cw _) = Just (cw, ow) span_op_has_width _ = Nothing -- | returns the number of columns to the character at the given position in the span op -columns_to_char_offset :: Word -> SpanOp -> Word +columns_to_char_offset :: Int -> SpanOp -> Int columns_to_char_offset cx (TextSpan _ _ utf8_str) = - let str = UTF8.toString utf8_str - in toEnum $! sum $! map wcwidth $! take (fromEnum cx) str + let str = TL.unpack (TL.decodeUtf8 utf8_str) + in wcswidth (take cx str) columns_to_char_offset _cx _ = error "columns_to_char_offset applied to span op without width" -- | Produces the span ops that will render the given picture, possibly cropped or padded, into the @@ -116,13 +127,41 @@ columns_to_char_offset _cx _ = error "columns_to_char_offset applied to span op spans_for_pic :: Picture -> DisplayRegion -> DisplayOps spans_for_pic pic r = DisplayOps r $ Vector.create (build_spans pic r) +-- transform plus clip. More or less. +newtype BlitState = BlitState + -- we always snoc to the operation vectors. Thus the column_offset = length of row at row_offset + { _row_offset :: Int + -- clip coordinate space is in image space. Which means it's >= 0 and < image_width. + , _skip_columns :: Int + -- >= 0 and < image_height + , _skip_rows :: Int + -- includes consideration of skip_columns. In display space. + -- The number of columns from the next column to be defined to the end of the display for the + -- row. + , _remaining_columns :: Int + -- includes consideration of skip_rows. In display space. + , _remaining_rows :: Int + } + +makeLenses ''BlitState + +newtype BlitEnv s = BlitEnv + { _bg :: Background + , _region :: DisplayRegion + , _mrow_ops :: MRowOps s + } + +makeLenses ''BlitEnv + +type BlitM s a = ReaderT (BlitEnv s) (StateT BlitState (ST s)) a + -- | Builds a vector of row operations that will output the given picture to the terminal. -- -- Crops to the given display region. build_spans :: Picture -> DisplayRegion -> ST s (MRowOps s) build_spans pic region = do -- First we create a mutable vector for each rows output operations. - mrow_ops <- Vector.replicate (fromEnum $ region_height region) Vector.empty + mrow_ops <- Vector.replicate (region_height region) Vector.empty -- \todo I think building the span operations in display order would provide better performance. -- However, I got stuck trying to implement an algorithm that did this. This will be considered -- as a possible future optimization. @@ -140,16 +179,13 @@ build_spans pic region = do -- display that image. The number of columns remaining in this row before exceeding the -- bounds is also provided. This is used to clip the span ops produced to the display. -- The skip dimensions provided do....??? - _ <- row_ops_for_image mrow_ops - (pic_image pic) - (pic_background pic) - region - (0,0) - 0 - (region_width region) - (fromEnum $ region_height region) + _ <- runStateT (runReaderT (start_image_build $ pic_image pic) + (BlitEnv (pic_background pic) region mrow_ops) + ) + (BlitState 0 0 0 0 (region_width region) (region_height region)) -- Fill in any unspecified columns with the background pattern. - forM_ [0 .. (fromEnum $ region_height region - 1)] $! \row -> do + -- todo: If there is no background pattern defined then skip + forM_ [0 .. (region_height region - 1)] $! \row -> do end_x <- Vector.read mrow_ops row >>= return . span_ops_effected_columns if end_x < region_width region then snoc_bg_fill mrow_ops (pic_background pic) (region_width region - end_x) row @@ -157,31 +193,39 @@ build_spans pic region = do else return () return mrow_ops --- | Add the operations required to build a given image to the current set of row operations. -row_ops_for_image :: MRowOps s -> Image -> Background -> DisplayRegion -> (Word, Word) -> Int -> Word -> Int -> ST s (Word, Word) -row_ops_for_image mrow_ops -- the image to output the ops to - image -- the image to rasterize in column order to mrow_ops - bg -- the background fill - region -- ??? - skip_dim@(skip_row,skip_col) -- the number of rows - y -- ??? - remaining_columns -- ??? - remain_rows - | remaining_columns == 0 = return skip_dim - | remain_rows == 0 = return skip_dim - | y >= fromEnum (region_height region) = return skip_dim - | otherwise = case image of - EmptyImage -> return skip_dim - -- The width provided is the number of columns this text span will occupy when displayed. - -- if this is greater than the number of remaining columsn the output has to be produced a - -- character at a time. - HorizText a text_str _ _ -> do - if skip_row > 0 - then return (skip_row - 1, skip_col) - else do - skip_col' <- snoc_text_span a text_str mrow_ops skip_col y remaining_columns - return (skip_row, skip_col') - VertJoin top_image bottom_image _ _ -> do +-- | Add the operations required to build a given image to the current set of row operations +-- returns the number of columns and rows contributed to the output. +start_image_build :: Image -> BlitM s () +start_image_build image = do + out_of_bounds <- is_out_of_bounds image <$> get + if out_of_bounds + then return (0,0) + else add_maybe_clipped image + +is_out_of_bounds :: Image -> BlitState -> Bool +is_out_of_bounds image s + | s ^. remaining_columns <= 0 = True + | s ^. remain_rows <= 0 = True + | otherwise = False + +add_maybe_clipped :: Image -> BlitM s () +add_maybe_clipped EmptyImage = return () +-- The width provided is the number of columns this text span will occupy when displayed. +-- if this is greater than the number of remaining columsn the output has to be produced a +-- character at a time. +-- +-- TODO: prove this cannot be called in fully clipped case +add_maybe_clipped (HorizText text_str _ow _cw) = + use row_offset >>= snoc_op (AttributeChange a) + left_clip <- use skip_columns + right_clip <- use remaining_columns + let left_clipped = left_clip > 0 + right_clipped = (ow - left_clip) > right_clip + if left_clipped || right_clipped + then let text_str' = clip_text left_clip right_clip + in render_unclipped_text_span text_str' + else render_unclipped_text_span text_str +process_image (VertJoin top_image bottom_image _ _) = do (skip_row',skip_col') <- row_ops_for_image mrow_ops top_image bg @@ -190,7 +234,7 @@ row_ops_for_image mrow_ops -- the image to output the ops t y remaining_columns remain_rows - let top_height = (fromEnum $! image_height top_image) - (fromEnum $! skip_row - skip_row') + let top_height = (image_height top_image) - (skip_row - skip_row') (skip_row'',skip_col'') <- row_ops_for_image mrow_ops bottom_image bg @@ -210,9 +254,9 @@ row_ops_for_image mrow_ops -- the image to output the ops t (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')) remain_rows return (min skip_row' skip_row'', skip_col'') BGFill width height -> do - let min_height = if y + (fromEnum height) > (fromEnum $! region_height region) - then region_height region - (toEnum y) - else min height (toEnum remain_rows) + let min_height = if y + height > (region_height region) + then region_height region - y + else min height remain_rows min_width = min width remaining_columns actual_height = if skip_row > min_height then 0 @@ -220,7 +264,7 @@ row_ops_for_image mrow_ops -- the image to output the ops t actual_width = if skip_col > min_width then 0 else min_width - skip_col - forM_ [y .. y + fromEnum actual_height - 1] $! \y' -> snoc_bg_fill mrow_ops bg actual_width y' + forM_ [y .. y + actual_height - 1] $! \y' -> snoc_bg_fill mrow_ops bg actual_width y' let skip_row' = if actual_height > skip_row then 0 else skip_row - min_height @@ -228,101 +272,37 @@ row_ops_for_image mrow_ops -- the image to output the ops t then 0 else skip_col - min_width return (skip_row',skip_col') - Translation (dx,dy) i -> do - if dx < 0 - -- Translation left - -- Extract the delta and add it to skip_col. - then row_ops_for_image mrow_ops (translate (0, dy) i) bg region (skip_row, skip_col + dw) y remaining_columns remain_rows - -- Translation right - else if dy < 0 - -- Translation up - -- Extract the delta and add it to skip_row. - then row_ops_for_image mrow_ops (translate (dx, 0) i) bg region (skip_row + dh, skip_col) y remaining_columns remain_rows - -- Translation down - -- Pad the start of lines and above the image with a - -- background_fill image - else row_ops_for_image mrow_ops (background_fill ow dh <-> (background_fill dw ih <|> i)) bg region skip_dim y remaining_columns remain_rows - where - dw = toEnum $ abs dx - dh = toEnum $ abs dy - ow = image_width image - ih = image_height i ImageCrop (max_w,max_h) i -> - row_ops_for_image mrow_ops i bg region skip_dim y (min remaining_columns max_w) (min remain_rows $ fromEnum max_h) - ImagePad (min_w,min_h) i -> do - let hpad = if image_width i < min_w - then background_fill (min_w - image_width i) (image_height i) - else empty_image - let vpad = if image_height i < min_h - then background_fill (image_width i) (min_h - image_height i) - else empty_image - row_ops_for_image mrow_ops ((i <|> hpad) <-> vpad) bg region skip_dim y remaining_columns remain_rows + row_ops_for_image mrow_ops i bg region skip_dim y (min remaining_columns max_w) (min remain_rows max_h) -snoc_text_span :: Attr -- the display attributes of the text span - -> DisplayString -- the text to output - -> MRowOps s -- the display operations to add to - -> Word -- the number of display columns in the text span to - -- skip before outputting - -> Int -- the row of the display operations to add to - -> Word -- the number of columns from the next column to be - -- defined to the end of the display for the row. - -> ST s Word -snoc_text_span a text_str mrow_ops columns_to_skip y remaining_columns = do - {-# SCC "snoc_text_span-pre" #-} snoc_op mrow_ops y $! AttributeChange a - -- At most a text span will consist of remaining_columns characters - -- we keep track of the position of the next character. - let max_len :: Int = fromEnum remaining_columns - mspan_chars <- Vector.new max_len - ( used_display_columns, display_columns_skipped, used_char_count ) - <- {-# SCC "snoc_text_span-foldlM" #-} Foldable.foldlM (build_text_span mspan_chars) ( 0, 0, 0 ) text_str - -- once all characters have been output to mspan_chars we grab the used head - out_text <- Vector.unsafeFreeze $! Vector.take used_char_count mspan_chars - -- convert to UTF8 bytestring. - -- This could be made faster. Hopefully the optimizer does a fair job at fusing the fold - -- contained in fromString with the unfold in toList. No biggy right now then. - {-# SCC "snoc_text_span-post" #-} snoc_op mrow_ops y $! TextSpan used_display_columns (toEnum used_char_count) - $! UTF8.fromString - $! Vector.toList out_text - return $ columns_to_skip - display_columns_skipped - where - build_text_span mspan_chars (!used_display_columns, !display_columns_skipped, !used_char_count) - (out_char, char_display_width) = {-# SCC "build_text_span" #-} - -- Only valid if the maximum width of a character is 2 display columns. - -- XXX: Optimize into a skip pass then clipped fill pass - if display_columns_skipped == columns_to_skip - then if used_display_columns == remaining_columns - then return $! ( used_display_columns, display_columns_skipped, used_char_count ) - else if ( used_display_columns + char_display_width ) > remaining_columns - then do - Vector.unsafeWrite mspan_chars used_char_count '…' - return $! ( used_display_columns + 1 - , display_columns_skipped - , used_char_count + 1 - ) - else do - Vector.unsafeWrite mspan_chars used_char_count out_char - return $! ( used_display_columns + char_display_width - , display_columns_skipped - , used_char_count + 1 - ) - else if (display_columns_skipped + char_display_width) > columns_to_skip - then do - Vector.unsafeWrite mspan_chars used_char_count '…' - return $! ( used_display_columns + 1 - , columns_to_skip - , used_char_count + 1 - ) - else return $ ( used_display_columns - , display_columns_skipped + char_display_width - , used_char_count - ) +render_clipped_text_span :: DisplayString -> Int -> Int -> BlitM () +render_clipped_text_span txt left_skip right_clip = do + use row_offset >>= snoc_op (AttributeChange a) + -- TODO: store a skip list in HorizText + let (to_drop,pad_prefix) = clip_for_char_width left_skip txt 0 + txt' = TL.append (if pad_prefix then TL.singleton '…' else TL.empty) (TL.drop to_drop txt) + (to_take,pad_suffix) = clip_for_char_width right_clip txt' 0 + txt'' = TL.append (TL.take to_take txt') (if pad_suffix then TL.singleton '…' else TL.empty) + clip_for_char_width 0 _ n = (n, False) + clip_for_char_width 1 t n + | wcwidth (TL.head t) == 1 = (n+1, False) + | otherwise = (n, True) + clip_for_char_width lc t n + = apply_left_clip (lc - wcwidth (TL.head t)) (TL.rest t) (n + 1) + render_unclipped_text_span a txt'' + +render_unclipped_text_span :: DisplayString -> BlitM () +render_unclipped_text_span txt = do + let op = TextSpan used_display_columns (TL.length txt) (TL.encodeUtf8 txt) + used_display_columns = wcswidth $ TL.unpack txt + use row_offset >>= snoc_op op -- | Add a background fill of the given column width to the row display operations. -- -- This has a fast path for background characters that are a single column and a single byte. -- Otherwise this has to compute the width of the background character and replicate a sequence of -- bytes to fill in the required width. -snoc_bg_fill :: MRowOps s -> Background -> Word -> Int -> ST s () +snoc_bg_fill :: MRowOps s -> Background -> Int -> Int -> ST s () snoc_bg_fill _row_ops _bg 0 _row = return () snoc_bg_fill mrow_ops (Background c back_attr) fill_length row @@ -334,21 +314,23 @@ snoc_bg_fill mrow_ops (Background c back_attr) fill_length row then let !(c_byte :: Word8) = BInt.c2w c in unsafeIOToST $ do - BInt.create ( fromEnum fill_length ) + BInt.create fill_length $ \ptr -> mapM_ (\i -> pokeByteOff ptr i c_byte) - [0 .. fromEnum (fill_length - 1)] + [0 .. (fill_length - 1)] else let !(c_bytes :: [Word8]) = encode [c] in unsafeIOToST $ do - BInt.create (fromEnum fill_length * length c_bytes) + BInt.create (fill_length * length c_bytes) $ \ptr -> mapM_ (\(i,b) -> pokeByteOff ptr i b) - $ zip [0 .. fromEnum (fill_length - 1)] (cycle c_bytes) + $ zip [0 .. (fill_length - 1)] (cycle c_bytes) snoc_op mrow_ops row $ TextSpan fill_length fill_length (UTF8.fromRep utf8_bs) -- | snocs the operation to the operations for the given row. -snoc_op :: MRowOps s -> Int -> SpanOp -> ST s () -snoc_op !mrow_ops !row !op = do - ops <- Vector.read mrow_ops row - let ops' = Vector.snoc ops op - Vector.write mrow_ops row ops' +snoc_op :: SpanOp -> Int -> BlitM s () +snoc_op !op !row = do + the_mrow_ops <- view mrow_ops + lift $ do + ops <- Vector.read the_mrow_ops row + let ops' = Vector.snoc ops op + Vector.write the_mrow_ops row ops' diff --git a/test/current_benchmark_results.txt b/test/current_benchmark_results.txt new file mode 100644 index 0000000..14c093f --- /dev/null +++ b/test/current_benchmark_results.txt @@ -0,0 +1,16 @@ +starting no-diff-opt-0 +user time: 226 +system time: 13 +starting render-char-0 +user time: 411 +system time: 22 +starting render-char-1 +user time: 386 +system time: 21 +starting vertical-scroll-0 +user time: 1930 +system time: 96 +starting image-fuzz-0 +user time: 1225 +system time: 52 +[("no-diff-opt-0",226,13),("render-char-0",411,22),("render-char-1",386,21),("vertical-scroll-0",1930,96),("image-fuzz-0",1225,52)] diff --git a/vty.cabal b/vty.cabal index c7ac35c..728f31a 100644 --- a/vty.cabal +++ b/vty.cabal @@ -43,6 +43,7 @@ library containers, deepseq >= 1.1 && < 1.4, ghc-prim, + lens, mtl >= 1.1.1.0 && < 2.2, parallel >= 2.2 && < 3.3, parsec >= 2 && < 4, @@ -99,6 +100,7 @@ test-suite verify-attribute-ops containers, deepseq >= 1.1 && < 1.4, ghc-prim, + lens, mtl >= 1.1.1.0 && < 2.2, parallel >= 2.2 && < 3.3, parsec >= 2 && < 4, @@ -150,6 +152,7 @@ test-suite verify-using-mock-terminal containers, deepseq >= 1.1 && < 1.4, ghc-prim, + lens, mtl >= 1.1.1.0 && < 2.2, parallel >= 2.2 && < 3.3, parsec >= 2 && < 4, @@ -201,6 +204,7 @@ test-suite verify-display-attributes containers, deepseq >= 1.1 && < 1.4, ghc-prim, + lens, mtl >= 1.1.1.0 && < 2.2, parallel >= 2.2 && < 3.3, parsec >= 2 && < 4, @@ -229,6 +233,7 @@ test-suite verify-empty-image-props containers, deepseq >= 1.1 && < 1.4, ghc-prim, + lens, mtl >= 1.1.1.0 && < 2.2, parallel >= 2.2 && < 3.3, parsec >= 2 && < 4, @@ -260,6 +265,7 @@ test-suite verify-eval-terminfo-caps containers, deepseq >= 1.1 && < 1.4, ghc-prim, + lens, mtl >= 1.1.1.0 && < 2.2, parallel >= 2.2 && < 3.3, parsec >= 2 && < 4, @@ -303,6 +309,7 @@ test-suite verify-image-ops containers, deepseq >= 1.1 && < 1.4, ghc-prim, + lens, mtl >= 1.1.1.0 && < 2.2, parallel >= 2.2 && < 3.3, parsec >= 2 && < 4, @@ -340,6 +347,7 @@ test-suite verify-image-trans containers, deepseq >= 1.1 && < 1.4, ghc-prim, + lens, mtl >= 1.1.1.0 && < 2.2, parallel >= 2.2 && < 3.3, parsec >= 2 && < 4, @@ -387,6 +395,7 @@ test-suite verify-inline containers, deepseq >= 1.1 && < 1.4, ghc-prim, + lens, mtl >= 1.1.1.0 && < 2.2, parallel >= 2.2 && < 3.3, parsec >= 2 && < 4, @@ -418,6 +427,7 @@ test-suite verify-parse-terminfo-caps containers, deepseq >= 1.1 && < 1.4, ghc-prim, + lens, mtl >= 1.1.1.0 && < 2.2, parallel >= 2.2 && < 3.3, parsec >= 2 && < 4, @@ -448,6 +458,7 @@ test-suite verify-picture-ops containers, deepseq >= 1.1 && < 1.4, ghc-prim, + lens, mtl >= 1.1.1.0 && < 2.2, parallel >= 2.2 && < 3.3, parsec >= 2 && < 4, @@ -499,6 +510,7 @@ test-suite verify-picture-to-span containers, deepseq >= 1.1 && < 1.4, ghc-prim, + lens, mtl >= 1.1.1.0 && < 2.2, parallel >= 2.2 && < 3.3, parsec >= 2 && < 4, @@ -550,6 +562,7 @@ test-suite verify-span-ops containers, deepseq >= 1.1 && < 1.4, ghc-prim, + lens, mtl >= 1.1.1.0 && < 2.2, parallel >= 2.2 && < 3.3, parsec >= 2 && < 4, @@ -584,6 +597,7 @@ test-suite verify-utf8-width containers, deepseq >= 1.1 && < 1.4, ghc-prim, + lens, mtl >= 1.1.1.0 && < 2.2, parallel >= 2.2 && < 3.3, parsec >= 2 && < 4, @@ -610,6 +624,7 @@ executable vty-interactive-terminal-test containers, deepseq >= 1.1 && < 1.4, ghc-prim, + lens, mtl >= 1.1.1.0 && < 2.2, parallel >= 2.2 && < 3.3, parsec >= 2 && < 4, @@ -638,6 +653,7 @@ executable vty-benchmark containers, deepseq >= 1.1 && < 1.4, ghc-prim, + lens, mtl >= 1.1.1.0 && < 2.2, parallel >= 2.2 && < 3.3, parsec >= 2 && < 4,