about summary refs log tree commit diff
path: root/test/Xanthous/DataSpec.hs
diff options
context:
space:
mode:
authorGriffin Smith <root@gws.fyi>2020-01-09T04·01-0500
committerGriffin Smith <root@gws.fyi>2020-01-09T04·15-0500
commitb6f170c02cb8231238ba0909fd311efc83b6bf69 (patch)
treeeefa058e2be44c4aa97d23f918c68bcd493511f4 /test/Xanthous/DataSpec.hs
parent0f79a06733c30ddca4bc0746ddc99e1626775fff (diff)
Generate more reasonable doors
Generate doors at more reasonable positions, by:

- Only generating doors at the *ends* of hallways, where there's a
  tee-shaped opening
- Never generating two doors adjacent to each other
Diffstat (limited to 'test/Xanthous/DataSpec.hs')
-rw-r--r--test/Xanthous/DataSpec.hs36
1 files changed, 26 insertions, 10 deletions
diff --git a/test/Xanthous/DataSpec.hs b/test/Xanthous/DataSpec.hs
index a2fcdbba15e0..91dc6cea1ba5 100644
--- a/test/Xanthous/DataSpec.hs
+++ b/test/Xanthous/DataSpec.hs
@@ -1,9 +1,11 @@
 --------------------------------------------------------------------------------
 module Xanthous.DataSpec (main, test) where
 --------------------------------------------------------------------------------
-import Test.Prelude hiding (Right, Left, Down)
-import Xanthous.Data
+import Test.Prelude hiding (Right, Left, Down, toList, all)
 import Data.Group
+import Data.Foldable (toList, all)
+--------------------------------------------------------------------------------
+import Xanthous.Data
 --------------------------------------------------------------------------------
 
 main :: IO ()
@@ -44,14 +46,14 @@ test = testGroup "Xanthous.Data"
     , testProperty "asPosition isUnit" $ \dir ->
         dir /= Here ==> isUnit (asPosition dir)
     , testGroup "Move"
-      [ testCase "Up"        $ move Up mempty        @?= Position 0 (-1)
-      , testCase "Down"      $ move Down mempty      @?= Position 0 1
-      , testCase "Left"      $ move Left mempty      @?= Position (-1) 0
-      , testCase "Right"     $ move Right mempty     @?= Position 1 0
-      , testCase "UpLeft"    $ move UpLeft mempty    @?= Position (-1) (-1)
-      , testCase "UpRight"   $ move UpRight mempty   @?= Position 1 (-1)
-      , testCase "DownLeft"  $ move DownLeft mempty  @?= Position (-1) 1
-      , testCase "DownRight" $ move DownRight mempty @?= Position 1 1
+      [ testCase "Up"        $ move Up mempty        @?= Position @Int 0 (-1)
+      , testCase "Down"      $ move Down mempty      @?= Position @Int 0 1
+      , testCase "Left"      $ move Left mempty      @?= Position @Int (-1) 0
+      , testCase "Right"     $ move Right mempty     @?= Position @Int 1 0
+      , testCase "UpLeft"    $ move UpLeft mempty    @?= Position @Int (-1) (-1)
+      , testCase "UpRight"   $ move UpRight mempty   @?= Position @Int 1 (-1)
+      , testCase "DownLeft"  $ move DownLeft mempty  @?= Position @Int (-1) 1
+      , testCase "DownRight" $ move DownRight mempty @?= Position @Int 1 1
       ]
     ]
 
@@ -79,4 +81,18 @@ test = testGroup "Xanthous.Data"
                             (Box (V2 4 2) dims)
       ]
     ]
+
+  , testGroup "Neighbors"
+    [ testGroup "rotations"
+      [ testProperty "always has the same members"
+        $ \(neighs :: Neighbors Int) ->
+          all (\ns -> sort (toList ns) == sort (toList neighs))
+          $ rotations neighs
+      , testProperty "all rotations have the same rotations"
+        $ \(neighs :: Neighbors Int) ->
+          let rots = rotations neighs
+          in all (\ns -> sort (toList $ rotations ns) == sort (toList rots))
+             rots
+      ]
+    ]
   ]