diff options
author | sternenseemann <git@lukasepple.de> | 2019-05-30 11:16:11 +0200 |
---|---|---|
committer | sternenseemann <git@lukasepple.de> | 2019-05-30 11:16:16 +0200 |
commit | 4b7c378c321095d55fa3ef7ee0abcc018cc58d6b (patch) | |
tree | 618d9e37b107c6d024b472f068653ab60f049b92 | |
parent | 74326e2ee17f999a7048222e8cacbb1372a614fd (diff) |
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
-rw-r--r-- | grav2ty.cabal | 10 | ||||
-rw-r--r-- | grav2ty.nix | 11 | ||||
-rw-r--r-- | lib/Grav2ty/Util/UGraph.hs | 49 | ||||
-rw-r--r-- | test/Main.hs | 34 |
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 |