justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Use tasty for tests, fix bug in circOnLine

Browse Source
This commit is contained in:
justin
2021-12-14 11:50:01 +00:00
parent ec51efabca
commit 47391f3850
19 changed files with 143 additions and 113 deletions
Download Patch File Download Diff File Expand all files Collapse all files
test/Spec.hs
+68 -41
View File
@@ -1,51 +1,79 @@
import Test.QuickCheck
import Test.HUnit
--import Test.HUnit
import Test.Tasty
import Test.Tasty.QuickCheck
import Test.Tasty.HUnit
import Dodge.Room.CheckConsistency
import Geometry
import Dodge.LevelGen.StaticWalls
import Geometry
main :: IO ()
main = do
putStrLn "Running tests:"
quickCheck prop_looping
main = defaultMain $
testGroup "Tests"
[testGroup "Geometry tests" geometryTests]
nextPair :: Eq a => (a,a) -> [(a,a)] -> [(a,a)]
nextPair (_,y) = filter (\(x,_) -> x == y)
geometryTests =
[ testCase "intersectSegSegTest cross intersect" $
intersectSegSegTest (V2 1 0) (V2 1 2) (V2 0 1) (V2 2 1)
@?= True
, testCase "intersectSegSegTest v intersect" $
intersectSegSegTest (V2 0 0) (V2 1 0) (V2 0 0) (V2 0 1)
@?= True
, testCase "intersectSegSegTest miss" $
intersectSegSegTest (V2 1 0) (V2 1 2) (V2 0 0) (V2 0 2)
@?= False
, testCase "circOnSeg endpoint1" $
circOnSeg (V2 0 0) (V2 10 10) (V2 (-1) (-1)) 2
@?= True
, testCase "circOnSeg endpoint2" $
circOnSeg (V2 0 0) (V2 10 10) (V2 11 10) 2
@?= True
, testCase "circOnSeg mid" $
circOnSeg (V2 0 0) (V2 10 10) (V2 5 5) 2
@?= True
, testCase "circOnSeg mid" $
circOnSeg (V2 0 0) (V2 10 10) (V2 5 4) 2
@?= True
, testCase "circOnSeg miss endpoint1" $
circOnSeg (V2 0 0) (V2 10 10) (V2 (-1) (-1)) 1
@?= False
, testCase "circOnSeg miss endpoint2" $
circOnSeg (V2 0 0) (V2 10 10) (V2 11 10) 0.9
@?= False
, testCase "circOnSeg miss mid" $
circOnSeg (V2 0 0) (V2 10 10) (V2 7 3) 0.9
@?= False
]
isLooping :: Eq a => [(a,a)] -> Bool
isLooping xs = all (( == 1) . length . flip nextPair xs) xs
isLooping' :: Eq a => [(a,a)] -> Bool
isLooping' xs = all (f xs) xs
where
f ys (x,y) = length ins == length outs && length rins == length routs
where
ins = filter (\(a,b) -> a == x) ys
outs = filter (\(a,b) -> b == x) ys
rins = filter (\(a,b) -> a == y) ys
routs = filter (\(a,b) -> b == y) ys
polygonStrictlyConvex :: [Point2] -> Bool
polygonStrictlyConvex ps = True
--prop_looping :: [Point2] -> [WallP] -> Bool
prop_looping = forAllShrink genTris shrinkTris $ \tris ->
not (any ( \[a,b,c] -> isOnSeg a b c
|| isOnSeg a c b
|| isOnSeg b c a
) tris)
==> isLooping' (foldr cutWalls' [] tris)
shrinkTris [] = []
shrinkTris (x:xs) = xs : map (x :) (shrinkTris xs)
genTri = zip <$> trip <*> trip
where
trip = vectorOf 3 $ fromIntegral <$> choose (0,3::Int)
genTris = listOf genTri
--nextPair :: Eq a => (a,a) -> [(a,a)] -> [(a,a)]
--nextPair (_,y) = filter (\(x,_) -> x == y)
--
--isLooping :: Eq a => [(a,a)] -> Bool
--isLooping xs = all (( == 1) . length . flip nextPair xs) xs
--
--isLooping' :: Eq a => [(a,a)] -> Bool
--isLooping' xs = all (f xs) xs
-- where
-- f ys (x,y) = length ins == length outs && length rins == length routs
-- where
-- ins = filter (\(a,b) -> a == x) ys
-- outs = filter (\(a,b) -> b == x) ys
-- rins = filter (\(a,b) -> a == y) ys
-- routs = filter (\(a,b) -> b == y) ys
--
--polygonStrictlyConvex :: [Point2] -> Bool
--polygonStrictlyConvex ps = True
--
--
--shrinkTris [] = []
--shrinkTris (x:xs) = xs : map (x :) (shrinkTris xs)
--
--genTri = zip <$> trip <*> trip
-- where
-- trip = vectorOf 3 $ fromIntegral <$> choose (0,3::Int)
--
--genTris = listOf genTri
--extractLoops :: Eq a => [(a,a)] -> [[(a,a)]]
--extractLoops [] = []
@@ -54,4 +82,3 @@ genTris = listOf genTri
--
--[[(0.0,1.0),(3.0,4.0),(5.0,5.0)],[(2.0,0.0),(2.0,4.0),(1.0,1.0)],[(5.0,5.0),(2.0,2.0),(1.0,3.0)]]
--
testRoom rm = TestCase "Room links connected" (linksOnPath rm)