git.iko.soy/vty
on 207c508 help sign in
vty/test/VerifyImageOps.hs
175 lines 8.1 kB history raw
1{-# LANGUAGE ScopedTypeVariables #-}
2module VerifyImageOps where
4import Graphics.Vty.Attributes
5import Graphics.Vty.Image.Internal
6import Verify.Graphics.Vty.Image
8import Verify
10import Control.DeepSeq
12two_sw_horiz_concat :: SingleColumnChar -> SingleColumnChar -> Bool
13two_sw_horiz_concat (SingleColumnChar c1) (SingleColumnChar c2) =
14 image_width (char def_attr c1 <|> char def_attr c2) == 2
16many_sw_horiz_concat :: [SingleColumnChar] -> Bool
17many_sw_horiz_concat cs =
18 let chars = [ char | SingleColumnChar char <- cs ]
19 l = fromIntegral $ length cs
20 in image_width ( horiz_cat $ map (char def_attr) chars ) == l
22two_sw_vert_concat :: SingleColumnChar -> SingleColumnChar -> Bool
23two_sw_vert_concat (SingleColumnChar c1) (SingleColumnChar c2) =
24 image_height (char def_attr c1 <-> char def_attr c2) == 2
26horiz_concat_sw_assoc :: SingleColumnChar -> SingleColumnChar -> SingleColumnChar -> Bool
27horiz_concat_sw_assoc (SingleColumnChar c0) (SingleColumnChar c1) (SingleColumnChar c2) =
28 (char def_attr c0 <|> char def_attr c1) <|> char def_attr c2
29 ==
30 char def_attr c0 <|> (char def_attr c1 <|> char def_attr c2)
32two_dw_horiz_concat :: DoubleColumnChar -> DoubleColumnChar -> Bool
33two_dw_horiz_concat (DoubleColumnChar c1) (DoubleColumnChar c2) =
34 image_width (char def_attr c1 <|> char def_attr c2) == 4
36many_dw_horiz_concat :: [DoubleColumnChar] -> Bool
37many_dw_horiz_concat cs =
38 let chars = [ char | DoubleColumnChar char <- cs ]
39 l = fromIntegral $ length cs
40 in image_width ( horiz_cat $ map (char def_attr) chars ) == l * 2
42two_dw_vert_concat :: DoubleColumnChar -> DoubleColumnChar -> Bool
43two_dw_vert_concat (DoubleColumnChar c1) (DoubleColumnChar c2) =
44 image_height (char def_attr c1 <-> char def_attr c2) == 2
46horiz_concat_dw_assoc :: DoubleColumnChar -> DoubleColumnChar -> DoubleColumnChar -> Bool
47horiz_concat_dw_assoc (DoubleColumnChar c0) (DoubleColumnChar c1) (DoubleColumnChar c2) =
48 (char def_attr c0 <|> char def_attr c1) <|> char def_attr c2
49 ==
50 char def_attr c0 <|> (char def_attr c1 <|> char def_attr c2)
52vert_contat_single_row :: NonEmptyList SingleRowSingleAttrImage -> Bool
53vert_contat_single_row (NonEmpty stack) =
54 let expected_height :: Int = length stack
55 stack_image = vert_cat [ i | SingleRowSingleAttrImage { row_image = i } <- stack ]
56 in image_height stack_image == expected_height
58disjoint_height_horiz_join :: NonEmptyList SingleRowSingleAttrImage
59 -> NonEmptyList SingleRowSingleAttrImage
60 -> Bool
61disjoint_height_horiz_join (NonEmpty stack_0) (NonEmpty stack_1) =
62 let expected_height :: Int = max (length stack_0) (length stack_1)
63 stack_image_0 = vert_cat [ i | SingleRowSingleAttrImage { row_image = i } <- stack_0 ]
64 stack_image_1 = vert_cat [ i | SingleRowSingleAttrImage { row_image = i } <- stack_1 ]
65 in image_height (stack_image_0 <|> stack_image_1) == expected_height
68disjoint_height_horiz_join_bg_fill :: NonEmptyList SingleRowSingleAttrImage
69 -> NonEmptyList SingleRowSingleAttrImage
70 -> Bool
71disjoint_height_horiz_join_bg_fill (NonEmpty stack_0) (NonEmpty stack_1) =
72 let stack_image_0 = vert_cat [ i | SingleRowSingleAttrImage { row_image = i } <- stack_0 ]
73 stack_image_1 = vert_cat [ i | SingleRowSingleAttrImage { row_image = i } <- stack_1 ]
74 image = stack_image_0 <|> stack_image_1
75 expected_height = image_height image
76 in case image of
77 HorizJoin {} -> ( expected_height == (image_height $ part_left image) )
78 &&
79 ( expected_height == (image_height $ part_right image) )
80 _ -> True
82disjoint_width_vert_join :: NonEmptyList SingleRowSingleAttrImage
83 -> NonEmptyList SingleRowSingleAttrImage
84 -> Bool
85disjoint_width_vert_join (NonEmpty stack_0) (NonEmpty stack_1) =
86 let expected_width = maximum $ map image_width (stack_0_images ++ stack_1_images)
87 stack_0_images = [ i | SingleRowSingleAttrImage { row_image = i } <- stack_0 ]
88 stack_1_images = [ i | SingleRowSingleAttrImage { row_image = i } <- stack_1 ]
89 stack_0_image = vert_cat stack_0_images
90 stack_1_image = vert_cat stack_1_images
91 image = stack_0_image <-> stack_1_image
92 in image_width image == expected_width
94disjoint_width_vert_join_bg_fill :: NonEmptyList SingleRowSingleAttrImage
95 -> NonEmptyList SingleRowSingleAttrImage
96 -> Bool
97disjoint_width_vert_join_bg_fill (NonEmpty stack_0) (NonEmpty stack_1) =
98 let expected_width = maximum $ map image_width (stack_0_images ++ stack_1_images)
99 stack_0_images = [ i | SingleRowSingleAttrImage { row_image = i } <- stack_0 ]
100 stack_1_images = [ i | SingleRowSingleAttrImage { row_image = i } <- stack_1 ]
101 stack_0_image = vert_cat stack_0_images
102 stack_1_image = vert_cat stack_1_images
103 image = stack_0_image <-> stack_1_image
104 in case image of
105 VertJoin {} -> ( expected_width == (image_width $ part_top image) )
106 &&
107 ( expected_width == (image_width $ part_bottom image) )
108 _ -> True
110translation_is_linear_on_out_size :: Translation -> Bool
111translation_is_linear_on_out_size (Translation i (x,y) i') =
112 image_width i' == image_width i + x && image_height i' == image_height i + y
114padding_is_linear_on_out_size :: Image -> Gen Bool
115padding_is_linear_on_out_size i = do
116 l <- offset
117 t <- offset
118 r <- offset
119 b <- offset
120 let i' = pad l t r b i
121 return $ image_width i' == image_width i + l + r && image_height i' == image_height i + t + b
122 where offset = choose (1,1024)
124crop_left_limits_width :: Image -> Int -> Property
125crop_left_limits_width i v = v >= 0 ==>
126 v >= image_width (crop_left v i)
128crop_right_limits_width :: Image -> Int -> Property
129crop_right_limits_width i v = v >= 0 ==>
130 v >= image_width (crop_right v i)
132crop_top_limits_height :: Image -> Int -> Property
133crop_top_limits_height i v = v >= 0 ==>
134 v >= image_height (crop_top v i)
136crop_bottom_limits_height :: Image -> Int -> Property
137crop_bottom_limits_height i v = v >= 0 ==>
138 v >= image_height (crop_bottom v i)
140-- rediculous tests just to satisfy my desire for nice code coverage :-P
141can_show_image :: Image -> Bool
142can_show_image i = length (show i) > 0
144can_rnf_image :: Image -> Bool
145can_rnf_image i = rnf i == ()
147can_pp_image :: Image -> Bool
148can_pp_image i = length (pp_image_structure i) > 0
150tests :: IO [Test]
151tests = return
152 [ verify "two_sw_horiz_concat" two_sw_horiz_concat
153 , verify "many_sw_horiz_concat" many_sw_horiz_concat
154 , verify "two_sw_vert_concat" two_sw_vert_concat
155 , verify "horiz_concat_sw_assoc" horiz_concat_sw_assoc
156 , verify "many_dw_horiz_concat" many_dw_horiz_concat
157 , verify "two_dw_horiz_concat" two_dw_horiz_concat
158 , verify "two_dw_vert_concat" two_dw_vert_concat
159 , verify "horiz_concat_dw_assoc" horiz_concat_dw_assoc
160 , verify "single row vert concats to correct height" vert_contat_single_row
161 , verify "disjoint_height_horiz_join" disjoint_height_horiz_join
162 , verify "disjoint_height_horiz_join BG fill" disjoint_height_horiz_join_bg_fill
163 , verify "disjoint_width_vert_join" disjoint_width_vert_join
164 , verify "disjoint_width_vert_join BG fill" disjoint_width_vert_join_bg_fill
165 , verify "translation effects output dimensions linearly" translation_is_linear_on_out_size
166 , verify "padding effects output dimensions linearly" padding_is_linear_on_out_size
167 , verify "crop left limits width" crop_left_limits_width
168 , verify "crop right limits width" crop_right_limits_width
169 , verify "crop top limits height" crop_top_limits_height
170 , verify "crop bottom limits height" crop_bottom_limits_height
171 , verify "can show image" can_show_image
172 , verify "can rnf image" can_rnf_image
173 , verify "can pp image" can_pp_image
174 ]