diff --git a/BenchImageFuzz.hs b/BenchImageFuzz.hs new file mode 100644 --- /dev/null +++ b/BenchImageFuzz.hs @@ -0,0 +1,31 @@ +module BenchImageFuzz where +import Graphics.Vty +import Graphics.Vty.Debug + +import Verify.Graphics.Vty.Image +import Verify + +import Control.Applicative +import Control.Monad + +import Data.Default (def) + +import System.Random + +rand :: Arbitrary a => IO a +rand = head <$> sample' arbitrary + +randomImage :: IO Image +randomImage = rand + +randomPicture = picForImage <$> randomImage + +bench0 = do + vty <- mkVty def + (w,h) <- displayBounds $ outputIface vty + let pictures = replicateM 3000 randomPicture + bench ps = do + forM ps (update vty) + shutdown vty + return $ Bench pictures bench + diff --git a/BenchNoDiffOpt.hs b/BenchNoDiffOpt.hs new file mode 100644 --- /dev/null +++ b/BenchNoDiffOpt.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE BangPatterns #-} +module BenchNoDiffOpt where + +{-# LANGUAGE BangPatterns #-} +import Graphics.Vty +import Verify + +import Control.Concurrent( threadDelay ) +import Control.Monad( liftM2 ) + +import qualified Data.ByteString.Char8 as B +import Data.Default (def) +import Data.List + +import System.Environment( getArgs ) +import System.IO +import System.Random + +bench0 = do + let fixedGen = mkStdGen 0 + setStdGen fixedGen + vty <- mkVty def + (w,h) <- displayBounds $ outputIface vty + let images = return $ (image0, image1) + image0 = charFill defAttr 'X' w h + image1 = charFill defAttr '0' w h + bench d = do + flipOut vty 300 image0 image1 + shutdown vty + return $ Bench images bench + +flipOut vty n image0 image1 = + let !pLeft = picForImage image0 + !pRight = picForImage image1 + wLeft 0 = return () + wLeft n = update vty pLeft >> wRight (n-1) + wRight 0 = return () + wRight n = update vty pRight >> wLeft (n-1) + in wLeft n diff --git a/BenchRenderChar.hs b/BenchRenderChar.hs new file mode 100644 --- /dev/null +++ b/BenchRenderChar.hs @@ -0,0 +1,40 @@ +{- benchmarks composing images using the renderChar operation. + - This is what Yi uses in Yi.UI.Vty.drawText. Ideally a sequence of renderChar images horizontally + - composed should provide no worse performance than a fill render op. + -} +module BenchRenderChar where + +import Graphics.Vty +import Verify + +import Control.Monad ( forM_ ) + +import Data.Default (def) + +bench0 = do + vty <- mkVty def + (w,h) <- displayBounds $ outputIface vty + let testChars = return $ take 500 $ cycle $ [ c | c <- ['a'..'z']] + bench d = do + forM_ d $ \testChar -> do + let testImage = testImageUsingChar testChar w h + outPic = picForImage testImage + update vty outPic + shutdown vty + return $ Bench testChars bench + +testImageUsingChar c w h + = vertCat $ replicate (fromIntegral h) + $ horizCat $ map (char defAttr) (replicate (fromIntegral w) c) + +bench1 = do + vty <- mkVty def + (w,h) <- displayBounds $ outputIface vty + let testChars = return $ take 500 $ cycle $ [ c | c <- ['a'..'z']] + bench d = do + forM_ d $ \testChar -> do + let testImage = charFill defAttr testChar w h + outPic = picForImage testImage + update vty outPic + shutdown vty + return $ Bench testChars bench diff --git a/BenchVerticalScroll.hs b/BenchVerticalScroll.hs new file mode 100644 --- /dev/null +++ b/BenchVerticalScroll.hs @@ -0,0 +1,61 @@ +module BenchVerticalScroll where + +import Graphics.Vty hiding ( pad ) +import Verify + +import Control.Concurrent( threadDelay ) +import Control.Monad( liftM2 ) + +import Data.Default (def) +import Data.List +import Data.Word + +import System.Environment( getArgs ) +import System.IO +import System.Random + +bench0 = do + let fixedGen = mkStdGen 0 + setStdGen fixedGen + return $ Bench (return ()) (\() -> mkVty def >>= liftM2 (>>) run shutdown) + +run vt = mapM_ (\p -> update vt p) . benchgen =<< displayBounds (outputIface vt) + +-- Currently, we just do scrolling. +takem :: (a -> Int) -> Int -> [a] -> ([a],[a]) +takem len n [] = ([],[]) +takem len n (x:xs) | lx > n = ([], x:xs) + | True = let (tk,dp) = takem len (n - lx) xs in (x:tk,dp) + where lx = len x + +fold :: (a -> Int) -> [Int] -> [a] -> [[a]] +fold len [] xs = [] +fold len (ll:lls) xs = let (tk,dp) = takem len ll xs in tk : fold len lls dp + +lengths :: Int -> StdGen -> [Int] +lengths ml g = + let (x,g2) = randomR (0,ml) g + (y,g3) = randomR (0,x) g2 + in y : lengths ml g3 + +nums :: StdGen -> [(Attr, String)] +nums g = let (x,g2) = (random g :: (Int, StdGen)) + (c,g3) = random g2 + in ( if c then defAttr `withForeColor` red else defAttr + , shows x " " + ) : nums g3 + +pad :: Int -> Image -> Image +pad ml img = img <|> charFill defAttr ' ' (ml - imageWidth img) 1 + +clines :: StdGen -> Int -> [Image] +clines g maxll = map (pad maxll . horizCat . map (uncurry string)) + $ fold (length . snd) (lengths maxll g1) (nums g2) + where (g1,g2) = split g + +benchgen :: DisplayRegion -> [Picture] +benchgen (w,h) + = take 2000 $ map ((\i -> picForImage i) . vertCat . take (fromEnum h)) + $ tails + $ clines (mkStdGen 80) w + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,31 @@ +Copyright Stefan O'Rear 2006, Corey O'Connor 2008, Corey O'Connor 2009 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Stefan O'Rear nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/Verify.hs b/Verify.hs new file mode 100644 --- /dev/null +++ b/Verify.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} +module Verify ( module Verify + , module Control.Applicative + , module Control.DeepSeq + , module Control.Exception + , module Control.Monad + , module Test.QuickCheck + , module Test.QuickCheck.Modifiers + , module Text.Printf + , succeeded + , failed + , monadicIO + , liftIO + , liftBool + , Test(..) + , Prop.Result(..) + ) + where + +import Control.Exception ( bracket, try, SomeException(..) ) + +import Distribution.TestSuite hiding ( Result(..) ) +import qualified Distribution.TestSuite as TS + +import Test.QuickCheck hiding ( Result(..) ) +import qualified Test.QuickCheck as QC +import Test.QuickCheck.Modifiers +import Test.QuickCheck.Property hiding ( Result(..) ) +import qualified Test.QuickCheck.Property as Prop +import Test.QuickCheck.Monadic ( monadicIO ) + +import Text.Printf + +import qualified Codec.Binary.UTF8.String as UTF8 + +import Control.Applicative hiding ( (<|>) ) +import Control.DeepSeq +import Control.Monad ( forM, mapM, mapM_, forM_ ) +import Control.Monad.State.Strict + +import Numeric ( showHex ) + +verify :: Testable t => String -> t -> Test +verify testName p = Test $ TestInstance + { name = testName + , run = do + qcResult <- quickCheckWithResult (stdArgs {chatty = False}) p + case qcResult of + QC.Success {..} -> return $ Finished TS.Pass + QC.Failure {numShrinks,reason} -> return $ Finished + $ TS.Fail $ "After " + ++ show numShrinks ++ " shrinks determined failure to be: " + ++ show reason + _ -> return $ Finished $ TS.Fail "TODO(corey): add failure message" + , tags = [] + , options = [] + , setOption = \_ _ -> Left "no options supported" + } + +data SingleColumnChar = SingleColumnChar Char + deriving (Show, Eq) + +instance Arbitrary SingleColumnChar where + arbitrary = elements $ map SingleColumnChar [toEnum 0x21 .. toEnum 0x7E] + +data DoubleColumnChar = DoubleColumnChar Char + deriving (Eq) + +instance Show DoubleColumnChar where + show (DoubleColumnChar c) = "(0x" ++ showHex (fromEnum c) "" ++ ") ->" ++ UTF8.encodeString [c] + +instance Arbitrary DoubleColumnChar where + arbitrary = elements $ map DoubleColumnChar $ + [ toEnum 0x3040 .. toEnum 0x3098 ] + ++ [ toEnum 0x309B .. toEnum 0xA4CF ] + +liftIOResult :: Testable prop => IO prop -> Property +liftIOResult = ioProperty + +#if __GLASGOW_HASKELL__ <= 701 +instance Random Word where + random g = + let (i :: Int, g') = random g + in (toEnum i, g') + randomR (l,h) g = + let (i :: Int, g') = randomR (fromEnum l,fromEnum h) g + in (toEnum i, g') +#endif + +data Bench where + Bench :: forall v . NFData v => IO v -> (v -> IO ()) -> Bench + diff --git a/Verify/Data/Terminfo/Parse.hs b/Verify/Data/Terminfo/Parse.hs new file mode 100644 --- /dev/null +++ b/Verify/Data/Terminfo/Parse.hs @@ -0,0 +1,112 @@ +module Verify.Data.Terminfo.Parse ( module Verify.Data.Terminfo.Parse + , module Data.Terminfo.Parse + ) + where + +import Data.Terminfo.Parse +import Data.Terminfo.Eval +import Verify + +import Data.Word +import qualified Data.Vector.Unboxed as Vector + +import Numeric + +hexDump :: [Word8] -> String +hexDump bytes = foldr (\b s -> showHex b s) "" bytes + +data NonParamCapString = NonParamCapString String + deriving Show + +instance Arbitrary NonParamCapString where + arbitrary + = ( do + s <- listOf1 $ (choose (0, 255) >>= return . toEnum) `suchThat` (/= '%') + return $ NonParamCapString s + ) `suchThat` ( \(NonParamCapString str) -> length str < 255 ) + +data LiteralPercentCap = LiteralPercentCap String [Word8] + deriving ( Show ) + +instance Arbitrary LiteralPercentCap where + arbitrary + = ( do + NonParamCapString s <- arbitrary + (s', bytes) <- insertEscapeOp "%" [toEnum $ fromEnum '%'] s + return $ LiteralPercentCap s' bytes + ) `suchThat` ( \(LiteralPercentCap str _) -> length str < 255 ) + +data IncFirstTwoCap = IncFirstTwoCap String [Word8] + deriving ( Show ) + +instance Arbitrary IncFirstTwoCap where + arbitrary + = ( do + NonParamCapString s <- arbitrary + (s', bytes) <- insertEscapeOp "i" [] s + return $ IncFirstTwoCap s' bytes + ) `suchThat` ( \(IncFirstTwoCap str _) -> length str < 255 ) + +data PushParamCap = PushParamCap String Int [Word8] + deriving ( Show ) + +instance Arbitrary PushParamCap where + arbitrary + = ( do + NonParamCapString s <- arbitrary + n <- choose (1,9) + (s', bytes) <- insertEscapeOp ("p" ++ show n) [] s + return $ PushParamCap s' n bytes + ) `suchThat` ( \(PushParamCap str _ _) -> length str < 255 ) + +data DecPrintCap = DecPrintCap String Int [Word8] + deriving ( Show ) + +instance Arbitrary DecPrintCap where + arbitrary + = ( do + NonParamCapString s <- arbitrary + n <- choose (1,9) + (s', bytes) <- insertEscapeOp ("p" ++ show n ++ "%d") [] s + return $ DecPrintCap s' n bytes + ) `suchThat` ( \(DecPrintCap str _ _) -> length str < 255 ) + +insertEscapeOp opStr replBytes s = do + insertPoints <- listOf1 $ elements [0 .. length s - 1] + let s' = f s ('%' : opStr) + remainingBytes = f (map (toEnum . fromEnum) s) replBytes + f inVs out_v = concat [ vs + | vi <- zip inVs [0 .. length s - 1] + , let vs = fst vi : ( if snd vi `elem` insertPoints + then out_v + else [] + ) + ] + return (s', remainingBytes) + +isBytesOp :: CapOp -> Bool +isBytesOp (Bytes {}) = True +-- isBytesOp _ = False + +bytesForRange cap offset count + = Vector.toList $ Vector.take count $ Vector.drop offset $ capBytes cap + +collectBytes :: CapExpression -> [Word8] +collectBytes e = concat [ bytes + | Bytes offset count <- capOps e + , let bytes = bytesForRange e offset count + ] + + +verifyBytesEqual :: [Word8] -> [Word8] -> Result +verifyBytesEqual outBytes expectedBytes + = if outBytes == expectedBytes + then succeeded + else failed + { reason = "outBytes [" + ++ hexDump outBytes + ++ "] /= expectedBytes [" + ++ hexDump expectedBytes + ++ "]" + } + diff --git a/Verify/Graphics/Vty/Attributes.hs b/Verify/Graphics/Vty/Attributes.hs new file mode 100644 --- /dev/null +++ b/Verify/Graphics/Vty/Attributes.hs @@ -0,0 +1,73 @@ +module Verify.Graphics.Vty.Attributes ( module Verify.Graphics.Vty.Attributes + , module Graphics.Vty.Attributes + ) + where + +import Graphics.Vty.Attributes +import Verify + +import Data.List ( delete ) + +allColors :: [Color] +allColors = + [ black + , red + , green + , yellow + , blue + , magenta + , cyan + , white + , brightBlack + , brightRed + , brightGreen + , brightYellow + , brightBlue + , brightMagenta + , brightCyan + , brightWhite + ] ++ map Color240 [0..239] + +allStyles :: [Style] +allStyles = + [ standout + , underline + , reverseVideo + , blink + , dim + , bold + ] + +-- Limit the possible attributes to just a few for now. +possibleAttrMods :: [ AttrOp ] +possibleAttrMods = + [ idOp + ] ++ map setForeColorOp allColors + ++ map setBackColorOp allColors + ++ map setStyleOp allStyles + +instance Arbitrary Attr where + arbitrary = elements possibleAttrMods >>= return . flip applyOp defAttr + +data DiffAttr = DiffAttr Attr Attr + +instance Arbitrary DiffAttr where + arbitrary = do + op0 <- elements possibleAttrMods + let possibleAttrMods' = delete op0 possibleAttrMods + op1 <- elements possibleAttrMods' + return $ DiffAttr (applyOp op0 defAttr) (applyOp op1 defAttr) + +data AttrOp = AttrOp String (Attr -> Attr) + +instance Eq AttrOp where + AttrOp n0 _ == AttrOp n1 _ = n0 == n1 + +setStyleOp s = AttrOp "set_style" (flip withStyle s) +setForeColorOp c = AttrOp "set_fore_color" (flip withForeColor c) +setBackColorOp c = AttrOp "set_back_color" (flip withBackColor c) +idOp = AttrOp "id" id + +applyOp :: AttrOp -> Attr -> Attr +applyOp (AttrOp _ f) a = f a + diff --git a/Verify/Graphics/Vty/Image.hs b/Verify/Graphics/Vty/Image.hs new file mode 100644 --- /dev/null +++ b/Verify/Graphics/Vty/Image.hs @@ -0,0 +1,218 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE DisambiguateRecordFields #-} +module Verify.Graphics.Vty.Image ( module Verify.Graphics.Vty.Image + , module Graphics.Vty.Image + ) + where + +import Verify.Graphics.Vty.Attributes +import Graphics.Vty.Image +import Graphics.Vty.Image.Internal + +import Verify + +data UnitImage = UnitImage Char Image + +instance Arbitrary UnitImage where + arbitrary = do + SingleColumnChar c <- arbitrary + a <- arbitrary + return $ UnitImage c (char a c) + +instance Show UnitImage where + show (UnitImage c _) = "UnitImage " ++ show c + +data DefaultImage = DefaultImage Image + +instance Show DefaultImage where + show (DefaultImage i) + = "DefaultImage (" ++ show i ++ ") " ++ show (imageWidth i, imageHeight i) + +instance Arbitrary DefaultImage where + arbitrary = do + i <- return $ char defAttr 'X' + return $ DefaultImage i + +data SingleRowSingleAttrImage + = SingleRowSingleAttrImage + { expectedAttr :: Attr + , expectedColumns :: Int + , rowImage :: Image + } + +instance Show SingleRowSingleAttrImage where + show (SingleRowSingleAttrImage attr columns image) + = "SingleRowSingleAttrImage (" ++ show attr ++ ") " ++ show columns ++ " ( " ++ show image ++ " )" + +newtype WidthResize = WidthResize (Image -> (Image, Int)) + +instance Arbitrary WidthResize where + arbitrary = do + WidthResize f <- arbitrary + w <- choose (1,64) + oneof $ map (return . WidthResize) + [ \i -> (i, imageWidth i) + , \i -> (resizeWidth w $ fst $ f i, w) + , \i -> let i' = fst $ f i in (cropLeft w i', min (imageWidth i') w) + , \i -> let i' = fst $ f i in (cropRight w i', min (imageWidth i') w) + ] + +newtype HeightResize = HeightResize (Image -> (Image, Int)) + +instance Arbitrary HeightResize where + arbitrary = do + HeightResize f <- arbitrary + h <- choose (1,64) + oneof $ map (return . HeightResize) + [ \i -> (i, imageHeight i) + , \i -> (resizeHeight h $ fst $ f i, h) + , \i -> let i' = fst $ f i in (cropTop h i', min (imageHeight i') h) + , \i -> let i' = fst $ f i in (cropBottom h i', min (imageHeight i') h) + ] + +newtype ImageResize = ImageResize (Image -> (Image, (Int, Int))) + +instance Arbitrary ImageResize where + arbitrary = oneof + [ return $! ImageResize $! \i -> (i, (imageWidth i, imageHeight i)) + , return $! ImageResize $! \i -> (i, (imageWidth i, imageHeight i)) + , return $! ImageResize $! \i -> (i, (imageWidth i, imageHeight i)) + , return $! ImageResize $! \i -> (i, (imageWidth i, imageHeight i)) + , return $! ImageResize $! \i -> (i, (imageWidth i, imageHeight i)) + , return $! ImageResize $! \i -> (i, (imageWidth i, imageHeight i)) + , do + ImageResize f <- arbitrary + WidthResize g <- arbitrary + return $! ImageResize $! \i -> + let (i0, (_, outHeight)) = f i + gI = g i0 + in (fst gI, (snd gI, outHeight)) + , do + ImageResize f <- arbitrary + HeightResize g <- arbitrary + return $! ImageResize $! \i -> + let (i0, (outWidth, _)) = f i + gI = g i0 + in (fst gI, (outWidth, snd gI)) + ] + + +instance Arbitrary SingleRowSingleAttrImage where + arbitrary = do + -- The text must contain at least one character. Otherwise the image simplifies to the + -- IdImage which has a height of 0. If this is to represent a single row then the height + -- must be 1 + singleColumnRowText <- Verify.resize 16 (listOf1 arbitrary) + a <- arbitrary + let outImage = horizCat $ [char a c | SingleColumnChar c <- singleColumnRowText] + outWidth = length singleColumnRowText + return $ SingleRowSingleAttrImage a outWidth outImage + +data SingleRowTwoAttrImage + = SingleRowTwoAttrImage + { part0 :: SingleRowSingleAttrImage + , part1 :: SingleRowSingleAttrImage + , joinImage :: Image + } deriving Show + +instance Arbitrary SingleRowTwoAttrImage where + arbitrary = do + p0 <- arbitrary + p1 <- arbitrary + return $ SingleRowTwoAttrImage p0 p1 (rowImage p0 <|> rowImage p1) + +data SingleAttrSingleSpanStack = SingleAttrSingleSpanStack + { stackImage :: Image + , stackSourceImages :: [SingleRowSingleAttrImage] + , stackWidth :: Int + , stackHeight :: Int + } + deriving Show + +instance Arbitrary SingleAttrSingleSpanStack where + arbitrary = do + imageList <- Verify.resize 16 (listOf1 arbitrary) + return $ mkSingleAttrSingleSpanStack imageList + shrink s = do + imageList <- shrink $ stackSourceImages s + if null imageList + then [] + else return $ mkSingleAttrSingleSpanStack imageList + +mkSingleAttrSingleSpanStack imageList = + let image = vertCat [ i | SingleRowSingleAttrImage { rowImage = i } <- imageList ] + in SingleAttrSingleSpanStack image imageList (maximum $ map expectedColumns imageList) + (toEnum $ length imageList) + +instance Arbitrary Image where + arbitrary = oneof + [ return EmptyImage + , do + SingleAttrSingleSpanStack {stackImage} <- Verify.resize 8 arbitrary + ImageResize f <- Verify.resize 2 arbitrary + return $! fst $! f stackImage + , do + SingleAttrSingleSpanStack {stackImage} <- Verify.resize 8 arbitrary + ImageResize f <- Verify.resize 2 arbitrary + return $! fst $! f stackImage + , do + i0 <- arbitrary + i1 <- arbitrary + let i = i0 <|> i1 + ImageResize f <- Verify.resize 2 arbitrary + return $! fst $! f i + , do + i0 <- arbitrary + i1 <- arbitrary + let i = i0 <-> i1 + ImageResize f <- Verify.resize 2 arbitrary + return $! fst $! f i + ] + {- + shrink i@(HorizJoin {partLeft, partRight}) = do + let !i_alt = backgroundFill (imageWidth i) (imageHeight i) + !partLeft' <- shrink partLeft + !partRight' <- shrink partRight + [i_alt, partLeft' <|> partRight'] + shrink i@(VertJoin {partTop, partBottom}) = do + let !i_alt = backgroundFill (imageWidth i) (imageHeight i) + !partTop' <- shrink partTop + !partBottom' <- shrink partBottom + [i_alt, partTop' <-> partBottom'] + shrink i@(CropRight {croppedImage, outputWidth}) = do + let !i_alt = backgroundFill (imageWidth i) (imageHeight i) + [i_alt, croppedImage] + shrink i@(CropLeft {croppedImage, leftSkip, outputWidth}) = do + let !i_alt = backgroundFill (imageWidth i) (imageHeight i) + [i_alt, croppedImage] + shrink i@(CropBottom {croppedImage, outputHeight}) = do + let !i_alt = backgroundFill (imageWidth i) (imageHeight i) + [i_alt, croppedImage] + shrink i@(CropTop {croppedImage, topSkip, outputHeight}) = do + let !i_alt = backgroundFill (imageWidth i) (imageHeight i) + [i_alt, croppedImage] + shrink i = [emptyImage, backgroundFill (imageWidth i) (imageHeight i)] + -} + +data CropOperation + = CropFromLeft + | CropFromRight + | CropFromTop + | CropFromBottom + deriving (Eq, Show) + +instance Arbitrary CropOperation where + arbitrary = oneof $ map return [CropFromLeft, CropFromRight, CropFromTop, CropFromBottom] + +data Translation = Translation Image (Int, Int) Image + deriving (Eq, Show) + +instance Arbitrary Translation where + arbitrary = do + i <- arbitrary + x <- arbitrary `suchThat` (> 0) + y <- arbitrary `suchThat` (> 0) + let i' = translate x y i + return $ Translation i (x,y) i' + diff --git a/vty-examples.cabal b/vty-examples.cabal --- a/vty-examples.cabal +++ b/vty-examples.cabal @@ -1,7 +1,7 @@ name: vty-examples -version: 5.4.0 +version: 5.5.0 license: BSD3 -license-file: ../LICENSE +license-file: LICENSE author: AUTHORS maintainer: Corey O'Connor (coreyoconnor@gmail.com) homepage: https://github.com/coreyoconnor/vty @@ -20,6 +20,10 @@ cabal-version: >= 1.18.0 build-type: Simple +source-repository head + type: git + location: https://github.com/coreyoconnor/vty.git + executable vty-interactive-terminal-test main-is: interactive_terminal_test.hs @@ -44,6 +48,9 @@ utf8-string, vector + other-modules: Verify.Data.Terminfo.Parse + Verify + executable vty-event-echo main-is: EventEcho.hs @@ -113,3 +120,9 @@ utf8-string, vector + other-modules: BenchImageFuzz + BenchNoDiffOpt + BenchRenderChar + BenchVerticalScroll + Verify.Graphics.Vty.Image + Verify.Graphics.Vty.Attributes