From 3a1b15aced79ce5e765a65f4c4b4451116040bba Mon Sep 17 00:00:00 2001
From: jgk <justin.g.kruger@gmail.com>
Date: Sat, 3 Apr 2021 13:43:56 +0200
Subject: [PATCH] Setup basic tests for wall carving

---
 src/Dodge/LevelGen/StaticWalls.hs |  2 ++
 test/Spec.hs                      | 34 ++++++++++++++++++++++++++++++-
 2 files changed, 35 insertions(+), 1 deletion(-)

diff --git a/src/Dodge/LevelGen/StaticWalls.hs b/src/Dodge/LevelGen/StaticWalls.hs
index aa307d422..6ec629ffc 100644
--- a/src/Dodge/LevelGen/StaticWalls.hs
+++ b/src/Dodge/LevelGen/StaticWalls.hs
@@ -48,6 +48,8 @@ checkWallLeft (x,y) wls = case filter (\(a,b) -> b == x ) wls of
 -- given a polygon of points and collection of walls, cuts out the polygon
 -- ie returns a new set of walls with a hole determined by anticlockwise ordering of the points
 cutWalls' :: [Point2] -> [WallP] -> [WallP]
+cutWalls' [] walls = walls
+cutWalls' [x,y] walls = walls
 cutWalls' qs walls = 
 --    nub
 --    . filter (not.wallIsZeroLength) 
diff --git a/test/Spec.hs b/test/Spec.hs
index cf937348d..55b42155a 100644
--- a/test/Spec.hs
+++ b/test/Spec.hs
@@ -1,4 +1,36 @@
 import Test.QuickCheck
 
+import Dodge.LevelGen.StaticWalls
+import Geometry
+
 main :: IO ()
-main = putStrLn "Test suite not yet implemented"
+main = do
+    putStrLn "Running tests:"
+    quickCheck prop_looping
+
+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
+
+polygonStrictlyConvex :: [Point2] -> Bool
+polygonStrictlyConvex ps = True
+
+--prop_looping :: [Point2] -> [WallP] -> Bool
+
+prop_looping = forAllShrink genTris shrinkTris $ \tris ->
+    isLooping $ foldr cutWalls' [] tris
+
+shrinkTris (x:xs) = xs : map (x :) (shrink xs)
+
+genTri = zip <$> trip <*> trip 
+  where
+    trip = vectorOf 3 $ choose (-500,500::Float)
+
+genTris = listOf genTri
+
+--extractLoops :: Eq a => [(a,a)] -> [[(a,a)]]
+--extractLoops [] = []
+--extractLoops (x:xs) = 
+