Unit testsHEADmaster

1 files changed, 138 insertions, 0 deletions

diff --git a/test/Tests.hs b/test/Tests.hs
new file mode 100644
index 0000000..1fcd7be
--- /dev/null
+++ b/test/Tests.hs
@@ -0,0 +1,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 ()