add UGraph Util and tests

this utility module is intended to improve performance.
in the future and might be reworked internally if i find
a better way to implement undirected graphs

4 files changed, 99 insertions, 5 deletions

diff --git a/grav2ty.cabal b/grav2ty.cabal
index 11b1a2d..0f706d2 100644
--- a/grav2ty.cabal
+++ b/grav2ty.cabal
@@ -21,7 +21,7 @@ extra-source-files:  CHANGELOG.md
 library grav2ty-lib
   exposed-modules:     Grav2ty.Simulation
                      , Grav2ty.Control
-  -- other-modules:
+                     , Grav2ty.Util.UGraph
   -- other-extensions:
   build-depends:       base ^>=4.12.0.0
                      , containers ^>=0.6.0.1
@@ -42,3 +42,11 @@ executable grav2ty
                      , grav2ty-lib
   hs-source-dirs:      src
   default-language:    Haskell2010
+
+test-suite lib-test
+  type:                exitcode-stdio-1.0
+  main-is:             test/Main.hs
+  build-depends:       base ^>=4.12.0.0
+                     , tasty ^>=1.2
+                     , tasty-quickcheck ^>=0.10
+                     , grav2ty-lib
diff --git a/grav2ty.nix b/grav2ty.nix
index d258069..4819a6c 100644
--- a/grav2ty.nix
+++ b/grav2ty.nix
@@ -1,14 +1,17 @@
-{ mkDerivation, base, containers, gloss, lens, linear, stdenv }:
+{ mkDerivation, base, containers, gloss, lens, linear, stdenv
+, tasty, tasty-quickcheck
+}:
 mkDerivation {
   pname = "grav2ty";
   version = "0.1.0.0";
   src = ./.;
   isLibrary = true;
   isExecutable = true;
-  enableLibraryProfiling = true;
-  enableExecutableProfiling = true;
   libraryHaskellDepends = [ base containers lens linear ];
-  executableHaskellDepends = [ base containers gloss linear ];
+  executableHaskellDepends = [ base containers gloss lens linear ];
+  testHaskellDepends = [ base tasty tasty-quickcheck ];
   doHaddock = true;
+  doCheck = true;
+  description = "a 2d space (ship) game with realistic physics-based gameplay";
   license = stdenv.lib.licenses.gpl3;
 }
diff --git a/lib/Grav2ty/Util/UGraph.hs b/lib/Grav2ty/Util/UGraph.hs
new file mode 100644
index 0000000..7d29b41
--- /dev/null
+++ b/lib/Grav2ty/Util/UGraph.hs
@@ -0,0 +1,49 @@
+module Grav2ty.Util.UGraph
+  (
+  -- * Interface
+    UGraph ()
+  , emptyU
+  , insertU
+  , insertSeq
+  , lookupU
+  -- * Props
+  , prop_undirected
+  , prop_undirected'
+  , prop_insertLookup
+  ) where
+
+import Data.Foldable
+import Data.Map.Strict (Map (..))
+import Data.Sequence (Seq (..), (<|))
+import qualified Data.Map.Strict as M
+
+newtype UGraph a v = UGraph { unUGraph :: Map a (Map a v) } deriving (Show, Read, Eq)
+
+emptyU :: UGraph a v
+emptyU = UGraph M.empty
+
+insertU :: Ord a => a -> a -> v -> UGraph a v -> UGraph a v
+insertU x y v = UGraph . M.alter (alterOuter x) y . M.alter (alterOuter y) x . unUGraph
+  where alterOuter i Nothing  = Just $ M.singleton i v
+        alterOuter i (Just m) = Just $ M.insert i v m
+
+insertSeq :: Ord a => Seq a -> (a -> a -> v) -> UGraph a v -> UGraph a v
+insertSeq seq f g = ins seq g
+  where ins (x :<| s) acc = ins s (foldl' (\g el -> insertU x el (f x el) g) acc s)
+        ins mempty acc = acc
+
+lookupU :: Ord a => a -> a -> UGraph a v -> Maybe v
+lookupU x y = (>>= (M.lookup y)) . M.lookup x . unUGraph
+
+prop_undirected' :: (Ord a, Eq v) => UGraph a v -> a -> a -> Bool
+prop_undirected' g x y = lookupU x y g == lookupU y x g
+
+prop_undirected :: (Ord a, Eq v) => UGraph a v -> Bool
+prop_undirected g = and . map (uncurry (prop_undirected' g)) $ allCombinations g
+
+prop_insertLookup :: (Ord a, Eq v) => a -> a -> v ->  Bool
+prop_insertLookup x y v = Just v == lookupU x y (insertU x y v emptyU)
+
+allCombinations :: UGraph a v -> [(a, a)]
+allCombinations (UGraph m) = foldl' (\l k -> map (\x -> (k, x)) keys ++ l) [] keys
+  where keys = M.keys m
diff --git a/test/Main.hs b/test/Main.hs
new file mode 100644
index 0000000..587f87c
--- /dev/null
+++ b/test/Main.hs
@@ -0,0 +1,34 @@
+module Main where
+
+import Test.Tasty as QC
+import Test.Tasty.QuickCheck as QC
+
+import Grav2ty.Util.UGraph
+
+times :: Monad m => Int -> a -> (a -> m a) -> m a
+times i res f = if i > 0
+                   then f res >>= flip (times (i - 1)) f
+                   else pure res
+
+instance (Ord a, Arbitrary a, Arbitrary v) => Arbitrary (UGraph a v) where
+  arbitrary = do
+    let g = emptyU
+    c <- arbitrary `suchThat` (>= 0)
+    times c g $ (\g -> do
+      x <- arbitrary
+      y <- arbitrary
+      v <- arbitrary
+      pure $ insertU x y v g)
+
+uGraph :: TestTree
+uGraph = testGroup "Grav2ty.Util.UGraph"
+  [ QC.testProperty "Check undirectedness" (prop_undirected :: UGraph Int Bool -> Bool)
+  , QC.testProperty "Check undirectedness (with vertices not in the graph)" (prop_undirected' :: UGraph Char Int -> Char -> Char -> Bool)
+  , QC.testProperty "Check insertion and lookup correctness" (prop_insertLookup :: Integer -> Integer ->  String -> Bool)
+  ]
+
+libTests :: TestTree
+libTests = testGroup "Grav2ty Library Tests" [ uGraph ]
+
+main :: IO ()
+main = defaultMain libTests