1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
|
import Test.HUnit
import Graphics.Gloss.Data.Color
import Graphics.Gloss.Data.Picture
import Graphics.Gloss.Interface.Pure.Game
import Scratchy.Syntax
-- Test Pure
testPure :: Test
testPure = TestCase $ do
let p = Pure ()
case p of
Pure () -> return ()
_ -> assertFailure "Pure should construct correctly"
-- Test SetBackgroundColor construction
testSetBackgroundColorConstruct :: Test
testSetBackgroundColorConstruct = TestCase $ do
let p = SetBackgroundColor red (Pure ())
case p of
SetBackgroundColor c _ ->
assertEqual "Color should be red" c red
_ -> assertFailure "SetBackgroundColor should construct correctly"
-- Test combine SetBackgroundColor
testCombineSetBackgroundColor :: Test
testCombineSetBackgroundColor = TestCase $ do
let p1 = SetBackgroundColor red (Pure ())
p2 = SetBackgroundColor blue (Pure ())
combined = combine p1 p2
case combined of
SetBackgroundColor c (SetBackgroundColor _ (Pure ())) ->
assertEqual "First color should be red" c red
_ -> assertFailure "combine should nest SetBackgroundColor correctly"
-- Test NewSprite construction
testNewSpriteConstruct :: Test
testNewSpriteConstruct = TestCase $ do
let p = NewSprite (5, 5) (circleSolid 10) (\_ -> Pure ())
case p of
NewSprite cell _ _ -> do
assertEqual "Cell should be (5, 5)" cell (5, 5)
_ -> assertFailure "NewSprite should construct correctly"
-- Test OnKeyEvent construction
testOnKeyEventConstruct :: Test
testOnKeyEventConstruct = TestCase $ do
let p = OnKeyEvent (SpecialKey KeyDown) (Pure ()) (Pure ())
case p of
OnKeyEvent key _ _ ->
assertEqual "Key should be KeyDown" key (SpecialKey KeyDown)
_ -> assertFailure "OnKeyEvent should construct correctly"
-- Test OnTargetReached construction
testOnTargetReachedConstruct :: Test
testOnTargetReachedConstruct = TestCase $ do
let p = OnTargetReached 0 (\_ -> Pure ()) (Pure ())
case p of
OnTargetReached ptr _ _ ->
assertEqual "Sprite pointer should be 0" ptr 0
_ -> assertFailure "OnTargetReached should construct correctly"
-- Test After (timer) construction
testAfterConstruct :: Test
testAfterConstruct = TestCase $ do
let p = After 10 (Pure ()) (Pure ())
case p of
After dur _ _ ->
assertEqual "Duration should be 10" dur 10
_ -> assertFailure "After should construct correctly"
-- Test InspectCell construction
testInspectCellConstruct :: Test
testInspectCellConstruct = TestCase $ do
let p = InspectCell (0, 0) (\case
IsFree -> Pure ()
_ -> Pure ())
case p of
InspectCell cell _ ->
assertEqual "Cell should be (0, 0)" cell (0, 0)
_ -> assertFailure "InspectCell should construct correctly"
-- Test combine nesting
testCombineNesting :: Test
testCombineNesting = TestCase $ do
let p1 = SetBackgroundColor red (Pure ())
p2 = SetBackgroundColor blue (Pure ())
p3 = SetBackgroundColor green (Pure ())
combined = combine p1 (combine p2 p3)
case combined of
SetBackgroundColor _ _ -> return ()
_ -> assertFailure "combine should nest correctly"
-- Test dirVec
testDirVec :: Test
testDirVec = TestCase $ do
assertEqual "dirVec U" (dirVec U) (0, 1)
assertEqual "dirVec D" (dirVec D) (0, -1)
assertEqual "dirVec L" (dirVec L) (-1, 0)
assertEqual "dirVec R" (dirVec R) (1, 0)
-- Test nextCell
testNextCell :: Test
testNextCell = TestCase $ do
assertEqual "nextCell U (0,0)" (nextCell U (0, 0)) (0, 1)
assertEqual "nextCell D (5,5)" (nextCell D (5, 5)) (5, 4)
assertEqual "nextCell L (3,3)" (nextCell L (3, 3)) (2, 3)
assertEqual "nextCell R (2,2)" (nextCell R (2, 2)) (3, 2)
-- Test inBounds
testInBounds :: Test
testInBounds = TestCase $ do
assertBool "Center should be in bounds" (inBounds (15, 15))
assertBool "(0, 0) should be in bounds" (inBounds (0, 0))
assertBool "(29, 29) should be in bounds" (inBounds (29, 29))
assertBool "(-1, 0) should be out of bounds" (not (inBounds (-1, 0)))
assertBool "(30, 15) should be out of bounds" (not (inBounds (30, 15)))
assertBool "(15, -1) should be out of bounds" (not (inBounds (15, -1)))
-- Run all tests
allTests :: Test
allTests = TestList
[ TestLabel "Pure" testPure
, TestLabel "SetBackgroundColorConstruct" testSetBackgroundColorConstruct
, TestLabel "CombineSetBackgroundColor" testCombineSetBackgroundColor
, TestLabel "NewSpriteConstruct" testNewSpriteConstruct
, TestLabel "OnKeyEventConstruct" testOnKeyEventConstruct
, TestLabel "OnTargetReachedConstruct" testOnTargetReachedConstruct
, TestLabel "AfterConstruct" testAfterConstruct
, TestLabel "InspectCellConstruct" testInspectCellConstruct
, TestLabel "CombineNesting" testCombineNesting
, TestLabel "DirVec" testDirVec
, TestLabel "NextCell" testNextCell
, TestLabel "InBounds" testInBounds
]
main :: IO ()
main = runTestTT allTests >> return ()
|