Add new property tests for Bodies, Regions, Octants and Octrees

src/Lib.hs

@@ -17,6 +17,7 @@ module Lib (
   -- * Barnes-Hut
   Region(..),
   Octree(..),
+  isEmpty, isSingle, isNode,
   Octant(..),
   selectOctant,
   subOctree,
@@ -104,6 +105,18 @@ data Octree = Empty Region
             | Node Region Octree Octree Octree Octree Octree Octree Octree Octree
   deriving (Show, Eq)
 
+isEmpty :: Octree -> Bool
+isEmpty (Empty _) = True
+isEmpty _ = False
+
+isSingle :: Octree -> Bool
+isSingle (Single _ _) = True
+isSingle _ = False
+
+isNode :: Octree -> Bool
+isNode (Node _ _ _ _ _ _ _ _ _) = True
+isNode _ = False
+
 instance NFData Octree where
   rnf (Empty r) = rnf r
   rnf (Single r b) = rnf r `seq` rnf b

test/Tests.hs

@@ -40,19 +40,15 @@ unitTests = testGroup "Unit tests"
     $ updateAll 1 1 [] @?= []
   , testCase "updateAll 0 0.5 [earth]"
     $ updateAll 0 0.5 [earth] @?= [earth]
+  , testCase "isEmpty $ buildTree []"
+    $ assertBool "buildTree [] is not Empty" (isEmpty $ buildTree [])
   ]
 
 instance (Arbitrary a) => Arbitrary (V3 a) where
-  arbitrary = do
-    x <- arbitrary
-    y <- arbitrary
-    z <- arbitrary
-    return $ V3 x y z
+  arbitrary = V3 <$> arbitrary <*> arbitrary <*> arbitrary
   
 instance (Arbitrary (f a)) => Arbitrary (Point f a) where
-  arbitrary = do
-    x <- arbitrary
-    return $ P x
+  arbitrary = P <$> arbitrary
 
 instance Arbitrary Body where
   arbitrary = do
@@ -63,8 +59,40 @@ instance Arbitrary Body where
     speed <- arbitrary
     return $ Body name radius mass pos speed
 
+instance Arbitrary Region where
+  arbitrary = do
+    center <- arbitrary
+    centerOfMass <- arbitrary
+    Positive mass <- arbitrary
+    Positive diameter <- arbitrary
+    return $ Region center centerOfMass mass diameter
+
+instance Arbitrary Octant where
+  arbitrary = oneof $ map return [NED, NWD, SWD, SED, NEU, NWU, SWU, SEU]
+
+instance Arbitrary Octree where
+  arbitrary = sized genOctree
+
+genOctree :: Int -> Gen Octree
+genOctree 0 = Empty <$> arbitrary
+genOctree n =
+  let m = n `div` 2
+      genSubtree = genOctree m
+  in
+    oneof [ Empty <$> arbitrary
+          , Single <$> arbitrary <*> arbitrary
+          , Node <$> arbitrary <*> genSubtree <*> genSubtree <*> genSubtree <*>
+            genSubtree <*> genSubtree <*> genSubtree <*> genSubtree <*> genSubtree
+          ]
+    
+  
+
 propertyChecks :: TestTree
 propertyChecks = testGroup "Property tests (QuickCheck)"
   [ QC.testProperty "updateAll of a singleton"
     $ \body -> updateAll 0 0.5 ([body] :: [Body]) == [body]
+  , QC.testProperty "buildTree of a singleton"
+    $ \body -> isSingle (buildTree [body])
+  , QC.testProperty "buildTree of many bodies"
+    $ \bodies -> (length bodies < 2) || isNode (buildTree bodies)
   ]