Image.hs

{-# 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'