vty-5.36: test/VerifyImageOps.hs

{-# LANGUAGE ScopedTypeVariables #-}
module VerifyImageOps where

import Graphics.Vty.Attributes
import Graphics.Vty.Image.Internal
import Verify.Graphics.Vty.Image

import Verify

import Control.DeepSeq

twoSwHorizConcat :: SingleColumnChar -> SingleColumnChar -> Bool
twoSwHorizConcat (SingleColumnChar c1) (SingleColumnChar c2) =
    imageWidth (char defAttr c1 <|> char defAttr c2) == 2

manySwHorizConcat :: [SingleColumnChar] -> Bool
manySwHorizConcat cs =
    let chars = [ char | SingleColumnChar char <- cs ]
        l = fromIntegral $ length cs
    in imageWidth ( horizCat $ map (char defAttr) chars ) == l

twoSwVertConcat :: SingleColumnChar -> SingleColumnChar -> Bool
twoSwVertConcat (SingleColumnChar c1) (SingleColumnChar c2) =
    imageHeight (char defAttr c1 <-> char defAttr c2) == 2

horizConcatSwAssoc :: SingleColumnChar -> SingleColumnChar -> SingleColumnChar -> Bool
horizConcatSwAssoc (SingleColumnChar c0) (SingleColumnChar c1) (SingleColumnChar c2) =
    (char defAttr c0 <|> char defAttr c1) <|> char defAttr c2
    ==
    char defAttr c0 <|> (char defAttr c1 <|> char defAttr c2)

twoDwHorizConcat :: DoubleColumnChar -> DoubleColumnChar -> Bool
twoDwHorizConcat (DoubleColumnChar c1) (DoubleColumnChar c2) =
    imageWidth (char defAttr c1 <|> char defAttr c2) == 4

manyDwHorizConcat :: [DoubleColumnChar] -> Bool
manyDwHorizConcat cs =
    let chars = [ char | DoubleColumnChar char <- cs ]
        l = fromIntegral $ length cs
    in imageWidth ( horizCat $ map (char defAttr) chars ) == l * 2

twoDwVertConcat :: DoubleColumnChar -> DoubleColumnChar -> Bool
twoDwVertConcat (DoubleColumnChar c1) (DoubleColumnChar c2) =
    imageHeight (char defAttr c1 <-> char defAttr c2) == 2

horizConcatDwAssoc :: DoubleColumnChar -> DoubleColumnChar -> DoubleColumnChar -> Bool
horizConcatDwAssoc (DoubleColumnChar c0) (DoubleColumnChar c1) (DoubleColumnChar c2) =
    (char defAttr c0 <|> char defAttr c1) <|> char defAttr c2
    ==
    char defAttr c0 <|> (char defAttr c1 <|> char defAttr c2)

vertContatSingleRow :: NonEmptyList SingleRowSingleAttrImage -> Bool
vertContatSingleRow (NonEmpty stack) =
    let expectedHeight :: Int = length stack
        stackImage = vertCat [ i | SingleRowSingleAttrImage { rowImage = i } <- stack ]
    in imageHeight stackImage == expectedHeight

disjointHeightHorizJoin :: NonEmptyList SingleRowSingleAttrImage
                        -> NonEmptyList SingleRowSingleAttrImage
                        -> Bool
disjointHeightHorizJoin (NonEmpty stack0) (NonEmpty stack1) =
    let expectedHeight :: Int = max (length stack0) (length stack1)
        stackImage0 = vertCat [ i | SingleRowSingleAttrImage { rowImage = i } <- stack0 ]
        stackImage1 = vertCat [ i | SingleRowSingleAttrImage { rowImage = i } <- stack1 ]
    in imageHeight (stackImage0 <|> stackImage1) == expectedHeight


disjointHeightHorizJoinBgFill :: NonEmptyList SingleRowSingleAttrImage
                              -> NonEmptyList SingleRowSingleAttrImage
                              -> Bool
disjointHeightHorizJoinBgFill (NonEmpty stack0) (NonEmpty stack1) =
    let stackImage0 = vertCat [ i | SingleRowSingleAttrImage { rowImage = i } <- stack0 ]
        stackImage1 = vertCat [ i | SingleRowSingleAttrImage { rowImage = i } <- stack1 ]
        image = stackImage0 <|> stackImage1
        expectedHeight = imageHeight image
    in case image of
        HorizJoin {}  -> ( expectedHeight == (imageHeight $ partLeft image) )
                         &&
                         ( expectedHeight == (imageHeight $ partRight image) )
        _             -> True

disjointWidthVertJoin :: NonEmptyList SingleRowSingleAttrImage
                      -> NonEmptyList SingleRowSingleAttrImage
                      -> Bool
disjointWidthVertJoin (NonEmpty stack0) (NonEmpty stack1) =
    let expectedWidth = maximum $ map imageWidth (stack0Images ++ stack1Images)
        stack0Images = [ i | SingleRowSingleAttrImage { rowImage = i } <- stack0 ]
        stack1Images = [ i | SingleRowSingleAttrImage { rowImage = i } <- stack1 ]
        stack0Image = vertCat stack0Images
        stack1Image = vertCat stack1Images
        image = stack0Image <-> stack1Image
    in imageWidth image == expectedWidth

disjointWidthVertJoinBgFill :: NonEmptyList SingleRowSingleAttrImage
                            -> NonEmptyList SingleRowSingleAttrImage
                            -> Bool
disjointWidthVertJoinBgFill (NonEmpty stack0) (NonEmpty stack1) =
    let expectedWidth = maximum $ map imageWidth (stack0Images ++ stack1Images)
        stack0Images = [ i | SingleRowSingleAttrImage { rowImage = i } <- stack0 ]
        stack1Images = [ i | SingleRowSingleAttrImage { rowImage = i } <- stack1 ]
        stack0Image = vertCat stack0Images
        stack1Image = vertCat stack1Images
        image = stack0Image <-> stack1Image
    in case image of
        VertJoin {} -> ( expectedWidth == (imageWidth $ partTop image) )
                       &&
                       ( expectedWidth == (imageWidth $ partBottom image) )
        _           -> True

translationIsLinearOnOutSize :: Translation -> Bool
translationIsLinearOnOutSize (Translation i (x,y) i') =
    imageWidth i' == imageWidth i + x && imageHeight i' == imageHeight i + y

paddingIsLinearOnOutSize :: Image -> Gen Bool
paddingIsLinearOnOutSize i = do
    l <- offset
    t <- offset
    r <- offset
    b <- offset
    let i' = pad l t r b i
    return $ imageWidth i' == imageWidth i + l + r && imageHeight i' == imageHeight i + t + b
    where offset = choose (1,1024)

cropLeftLimitsWidth :: Image -> Int -> Property
cropLeftLimitsWidth i v = v >= 0 ==>
    v >= imageWidth (cropLeft v i)

cropRightLimitsWidth :: Image -> Int -> Property
cropRightLimitsWidth i v = v >= 0 ==>
    v >= imageWidth (cropRight v i)

cropTopLimitsHeight :: Image -> Int -> Property
cropTopLimitsHeight i v = v >= 0 ==>
    v >= imageHeight (cropTop v i)

cropBottomLimitsHeight :: Image -> Int -> Property
cropBottomLimitsHeight i v = v >= 0 ==>
    v >= imageHeight (cropBottom v i)

-- ridiculous tests just to satisfy my desire for nice code coverage :-P
canShowImage :: Image -> Bool
canShowImage i = length (show i) > 0

canRnfImage :: Image -> Bool
canRnfImage i = rnf i == ()

canPpImage :: Image -> Bool
canPpImage i = length (ppImageStructure i) > 0

tests :: IO [Test]
tests = return
    [ verify "twoSwHorizConcat" twoSwHorizConcat
    , verify "manySwHorizConcat" manySwHorizConcat
    , verify "twoSwVertConcat" twoSwVertConcat
    , verify "horizConcatSwAssoc" horizConcatSwAssoc
    , verify "manyDwHorizConcat" manyDwHorizConcat
    , verify "twoDwHorizConcat" twoDwHorizConcat
    , verify "twoDwVertConcat" twoDwVertConcat
    , verify "horizConcatDwAssoc" horizConcatDwAssoc
    , verify "single row vert concats to correct height" vertContatSingleRow
    , verify "disjointHeightHorizJoin" disjointHeightHorizJoin
    , verify "disjointHeightHorizJoin BG fill" disjointHeightHorizJoinBgFill
    , verify "disjointWidthVertJoin" disjointWidthVertJoin
    , verify "disjointWidthVertJoin BG fill" disjointWidthVertJoinBgFill
    , verify "translation effects output dimensions linearly" translationIsLinearOnOutSize
    , verify "padding effects output dimensions linearly" paddingIsLinearOnOutSize
    , verify "crop left limits width" cropLeftLimitsWidth
    , verify "crop right limits width" cropRightLimitsWidth
    , verify "crop top limits height" cropTopLimitsHeight
    , verify "crop bottom limits height" cropBottomLimitsHeight
    , verify "can show image" canShowImage
    , verify "can rnf image" canRnfImage
    , verify "can pp image" canPpImage
    ]