From 47391f38506de4dc89d2e1a0d39962e8e8b7c0b6 Mon Sep 17 00:00:00 2001 From: justin Date: Tue, 14 Dec 2021 11:50:01 +0000 Subject: [PATCH] Use tasty for tests, fix bug in circOnLine --- package.yaml | 13 ++- src/Dodge/Item/Weapon/BatteryGuns.hs | 41 ++++------ src/Dodge/Placement/Instance/Turret.hs | 2 +- src/Dodge/Room/Room.hs | 3 +- src/Dodge/WorldEvent/ThingsHit.hs | 3 +- src/Geometry.hs | 6 +- src/Geometry/Intersect.hs | 9 +- src/Geometry/LHS.hs | 2 +- src/IntMapHelp.hs | 3 +- src/MonadHelp.hs | 10 +++ src/Polyhedra.hs | 3 +- src/Quaternion.hs | 3 +- src/Render.hs | 4 +- src/Shape.hs | 3 +- src/ShapePicture.hs | 11 +-- src/Sound.hs | 18 ++-- src/StrictHelp.hs | 3 +- src/Tile.hs | 10 +-- test/Spec.hs | 109 +++++++++++++++---------- 19 files changed, 143 insertions(+), 113 deletions(-) diff --git a/package.yaml b/package.yaml index 3ae1ba63a..de5c38593 100644 --- a/package.yaml +++ b/package.yaml @@ -23,12 +23,12 @@ dependencies: - base >= 4.7 && < 5 - containers - unordered-containers -- heap + #- heap - sdl2 - sdl2-mixer -- text - OpenGL - OpenGLRaw +- text - raw-strings-qq - bytestring - lens @@ -36,7 +36,7 @@ dependencies: - fgl - random - bmp -- monad-loops + #- monad-loops - JuicyPixels - vector - dlist @@ -46,7 +46,6 @@ dependencies: - linear - aeson - directory -- QuickCheck - extra - primitive - streaming @@ -54,6 +53,12 @@ dependencies: - monad-parallel - parallel - Clipboard + # testing +- tasty +- tasty-hunit +- tasty-quickcheck + #- QuickCheck + #- HUnit library: source-dirs: src diff --git a/src/Dodge/Item/Weapon/BatteryGuns.hs b/src/Dodge/Item/Weapon/BatteryGuns.hs index cf5d306b4..a95e82690 100644 --- a/src/Dodge/Item/Weapon/BatteryGuns.hs +++ b/src/Dodge/Item/Weapon/BatteryGuns.hs @@ -3,8 +3,7 @@ module Dodge.Item.Weapon.BatteryGuns , teslaGun , tractorGun , makeLaserAt - ) - where + ) where import Dodge.Data import Dodge.Creature.HandPos import Dodge.Particle.TeslaArc @@ -27,11 +26,9 @@ import ShapePicture import Dodge.Picture import LensHelp ---import Data.Function ---import qualified Data.Sequence as Seq import Data.List +import Data.Bifunctor import System.Random ---import Data.Maybe import Data.Tuple import qualified Data.IntMap.Strict as IM teslaGun :: Item @@ -161,7 +158,7 @@ aTeslaArc cr w = set randGen g w aLaser :: Item -> Creature -> World -> World aLaser it cr = particles .:~ makeLaserAt phasev pos dir where - pos = _crPos cr +.+ (aimingMuzzlePos cr it) *.* unitVectorAtAngle dir + pos = _crPos cr +.+ aimingMuzzlePos cr it *.* unitVectorAtAngle dir dir = _crDir cr phasev = _phaseV . _itParams $ _crInv cr IM.! j j = _crInvSel cr @@ -171,34 +168,34 @@ makeLaserAt phasev pos dir = Particle { _ptDraw = const blank , _ptUpdate = moveLaser phasev pos dir } -moveLaser - :: Float -- ^ Phase velocity, controls deflection through windows +moveLaser :: Float -- ^ Phase velocity, controls deflection through windows -> Point2 -> Float -> World -> Particle -> (World, Maybe Particle) moveLaser phasev pos dir w pt - = ( hitEffect w + = ( damThingHitWith (Lasering 19) pos xp thHit w , Just pt {_ptDraw = const pic ,_ptUpdate = ptSimpleTime 0 } ) - where + where xp = pos +.+ 800 *.* unitVectorAtAngle dir + (thHit, ps) = f [] pos xp f :: [Wall] -> Point2 -> Point2 -> (Maybe (Point2,Either Creature Wall),[Point2]) - f seenWs x y = case find (h' seenWs) $ thingsHitExceptCrLongLine Nothing x y w of - --f seenWs x y = case find (h' seenWs) $ thingsHitExceptCr Nothing x y w of + f seenWs x y = case find (notseen seenWs) $ thingsHitExceptCrLongLine Nothing x y w of + --f seenWs x y = case find (notseen seenWs) $ thingsHitExceptCr Nothing x y w of Just (p,Right wl) - | _wlOpacity wl == SeeThrough -> addPoint p $ f (wl:seenWs) p (h x y wl p) + | _wlOpacity wl == SeeThrough -> second (p:) $ f (wl:seenWs) p (refract x y wl p) | otherwise -> (Just (p,Right wl), [p]) Just (p,obj) -> (Just (p,obj), [p]) Nothing -> (Nothing, [y]) - addPoint p (x,ps') = (x,p:ps') - h x y wl p - | isEntering = p +.+ rotateV angleRef normalDist - | otherwise = p +.+ rotateV angleRef' normalDist' + refract x y wl p + | isEntering = p +.+ rotateV angleRef (normalDist wlNormal) + | otherwise = p +.+ rotateV angleRef' (normalDist wlNormal') where wlNormal = vNormal $ uncurry (-.-) $ swap (_wlLine wl) - normalDist = magV (p -.- y) *.* normalizeV wlNormal + wlNormal' = vNormal $ uncurry (-.-) (_wlLine wl) + normalDist wlnormal = magV (p -.- y) *.* normalizeV wlnormal angleInc = piRange $ argV wlNormal - argV (x -.- y) angleRef | reflectExternal = angleInc @@ -208,8 +205,6 @@ moveLaser phasev pos dir w pt | a' > negate pi = a' | otherwise = a' + 2 * pi isEntering = not $ isLeftOf (x -.- y) (uncurry (-.-) (_wlLine wl)) - wlNormal' = vNormal $ uncurry (-.-) (_wlLine wl) - normalDist' = magV (p -.- y) *.* normalizeV wlNormal' angleInc' = piRange $ argV wlNormal' - argV (x -.- y) angleRef' | reflectInternal = angleInc' @@ -217,10 +212,8 @@ moveLaser phasev pos dir w pt reflectInternal = 1 < abs (phasev * sin angleInc') reflectExternal = 1 < abs (sin angleInc / phasev) - h' ws (_,Right wl) = not $ any (\w' -> _wlID w' == _wlID wl) ws - h' _ _ = True - (thHit, ps) = f [] pos xp - hitEffect = damThingHitWith (Lasering 19) pos xp thHit + notseen ws (_,Right wl) = not $ any (\w' -> _wlID w' == _wlID wl) ws + notseen _ _ = True pic = setLayer 1 $ pictures [ setDepth 19 . color (brightX 0 0.5 yellow) $ lineOfThickness 20 (pos:ps) , setDepth 19.5 . color (brightX 10 1 yellow) $ lineOfThickness 3 (pos:ps) diff --git a/src/Dodge/Placement/Instance/Turret.hs b/src/Dodge/Placement/Instance/Turret.hs index 48f0f2249..cefa5cde1 100644 --- a/src/Dodge/Placement/Instance/Turret.hs +++ b/src/Dodge/Placement/Instance/Turret.hs @@ -67,7 +67,7 @@ updateTurret rotSpeed mc w cid = IM.newKey (_creatures w') thecreature = defaultCreature & crID .~ cid - & crInv . at 0 ?~ (_tuWeapon (_mcType mc) & itDimension . dimPortage . handlePos -~ 20 + & crInv . at 0 ?~ (_tuWeapon (_mcType mc) & itDimension . dimPortage . handlePos -~ 10 & itConsumption . ammoLoaded .~ 1 ) & crPos .~ mcpos diff --git a/src/Dodge/Room/Room.hs b/src/Dodge/Room/Room.hs index fb25524d3..d0f6faadc 100644 --- a/src/Dodge/Room/Room.hs +++ b/src/Dodge/Room/Room.hs @@ -21,10 +21,11 @@ import Dodge.Room.Door import Dodge.Room.Airlock import Geometry import Tile +import MonadHelp import Control.Lens import Control.Monad.State -import Control.Monad.Loops +--import Control.Monad.Loops import System.Random import Data.Maybe import Data.Tree diff --git a/src/Dodge/WorldEvent/ThingsHit.hs b/src/Dodge/WorldEvent/ThingsHit.hs index c7894bf5f..84cd7c780 100644 --- a/src/Dodge/WorldEvent/ThingsHit.hs +++ b/src/Dodge/WorldEvent/ThingsHit.hs @@ -127,5 +127,6 @@ thingsHitLongLine sp ep w -- $ creaturesAlongLine sp ep w crPs = map (\cr -> ssaTriPoint ep (_crPos cr) sp (_crRad cr)) hitCrs wls = zip (map (fromJust . hitPoint) hitWls) (map Right hitWls) - hitWls = wallsOnLine sp ep $ wallsAlongLine sp ep w + --hitWls = wallsOnLine sp ep $ wallsAlongLine sp ep w + hitWls = wallsOnLine sp ep $ _walls w hitPoint wl = uncurry (intersectSegSeg sp ep) (_wlLine wl) diff --git a/src/Geometry.hs b/src/Geometry.hs index e2d6a8ef1..94ee2976b 100644 --- a/src/Geometry.hs +++ b/src/Geometry.hs @@ -193,8 +193,10 @@ circOnSeg :: Point2 -> Point2 -> Point2 -> Float -> Bool {-# INLINE circOnSeg #-} circOnSeg !p1 !p2 !c !rad = magV (p1 -.- c) <= rad || magV (p2 -.- c) <= rad - || isJustTrue (fmap (\p -> magV (p -.- c) < rad) y) +-- || isJustTrue (fmap (\p -> magV (p -.- c) < rad) y) + || intersectSegSegTest p1 p2 (c -.- thenormal) (c +.+ thenormal) where + thenormal = rad *.* vNormal (normalizeV $ p1 -.- p2) y = intersectSegLine p1 p2 c (c +.+ vNormal (p1 -.- p2)) isJustTrue (Just True) = True isJustTrue _ = False @@ -279,7 +281,7 @@ diffAngles x y -- Note this doesn't necessarily find ALL solutions, asin is a map not a function. ssaTri :: Float -> Float -> Float -> Float ssaTri ab bc a - | sin a == 0 = 0 + | sin a == 0 = ab - bc | bc == 0 = ab | otherwise = let c = asin ( (ab * sin a)/bc) diff --git a/src/Geometry/Intersect.hs b/src/Geometry/Intersect.hs index 9c4c47e03..faa33038b 100644 --- a/src/Geometry/Intersect.hs +++ b/src/Geometry/Intersect.hs @@ -77,6 +77,7 @@ intersectSegLine (V2 x1 y1) (V2 x2 y2) (V2 x3 y3) (V2 x4 y4) --u' = (y1-y2)*(x1-x3) - (x1-x2)*(y1-y3) -- | It is not always necessary to find a point of intersection, sometimes a -- test may suffice. +-- IS THIS CORRECT? -- TODO tests intersectSegSegTest :: Point2 -> Point2 @@ -84,11 +85,11 @@ intersectSegSegTest -> Point2 -> Bool {-# INLINE intersectSegSegTest #-} -intersectSegSegTest a' b' c' d' - = f a' b' c' d' && f c' d' a' b' +intersectSegSegTest x y z w + = f x y z w && f z w x y where - f a b c d = ( isLHS a b c && not (isLHS a b d) ) - || ( not (isLHS a b c) && isLHS a b d ) + f a b c d = ( not (isRHS a b c) && not (isLHS a b d) ) + || ( not (isLHS a b c) && not (isRHS a b d) ) intersectSegSegPreTest :: Point2 -> Point2 diff --git a/src/Geometry/LHS.hs b/src/Geometry/LHS.hs index ce9635edd..6f4f4b375 100644 --- a/src/Geometry/LHS.hs +++ b/src/Geometry/LHS.hs @@ -3,7 +3,7 @@ module Geometry.LHS , isRHS ) where import Geometry.Data --- | Test whether a point is on the LHS of a line. +-- | Test whether a point is stricly on the LHS of a line. -- Returns False if the line is of zero length. isLHS :: Point2 -- ^ First line point. diff --git a/src/IntMapHelp.hs b/src/IntMapHelp.hs index d111dad3e..00d358a6c 100644 --- a/src/IntMapHelp.hs +++ b/src/IntMapHelp.hs @@ -5,8 +5,7 @@ module IntMapHelp , insertWithNewKeys , swapKeys , findIndex - ) - where + ) where --import Data.List hiding (foldr,insert) import Data.IntMap.Strict {- | Find a key value one higher than any key in the map, or zero if the map is diff --git a/src/MonadHelp.hs b/src/MonadHelp.hs index bfeb2e583..be1cb0910 100644 --- a/src/MonadHelp.hs +++ b/src/MonadHelp.hs @@ -15,3 +15,13 @@ untilJustCount m = go 0 case mayx of Nothing -> go (i+1) Just x -> return (x,i) + +iterateUntil :: Monad m => (a -> Bool) -> m a -> m a +iterateUntil t m = do + x <- m + if t x + then return x + else iterateUntil t m + +iterateWhile :: Monad m => (a -> Bool) -> m a -> m a +iterateWhile t = iterateUntil (not . t) diff --git a/src/Polyhedra.hs b/src/Polyhedra.hs index 066622bb7..4ac416af4 100644 --- a/src/Polyhedra.hs +++ b/src/Polyhedra.hs @@ -8,8 +8,7 @@ module Polyhedra , boxXYZnobase , polyToGeoRender , polysToPic - ) - where + ) where import Geometry import Polyhedra.Data import Picture.Data diff --git a/src/Quaternion.hs b/src/Quaternion.hs index f99f6c51e..86856a500 100644 --- a/src/Quaternion.hs +++ b/src/Quaternion.hs @@ -1,7 +1,6 @@ module Quaternion ( rotateToZ - ) - where + ) where import Geometry.Data import Geometry.Vector3D import qualified Linear.Quaternion as Q diff --git a/src/Render.hs b/src/Render.hs index 2bfd25af8..5a2272e6a 100644 --- a/src/Render.hs +++ b/src/Render.hs @@ -6,8 +6,7 @@ module Render , pingPongBetween , bindTO , bindFBO - ) - where + ) where import Shader import Shader.ExtraPrimitive import Shader.Data @@ -49,6 +48,7 @@ createLightMap pdata lightPoints nWalls nSils nCaps toPos = do -- for each of the lights: -- 1. stencil out the walls from this light's point of view -- 2. calculate lighting based on each fragment's position + -- to consider: adding normals/a "material" for each fragment blendFunc $= (Zero, OneMinusSrcColor) stencilTest $= Enabled flip VS.mapM_ (VS.fromList lightPoints) $ \(V3 x y z,rad,V3 r g b) -> do diff --git a/src/Shape.hs b/src/Shape.hs index 77b284ea3..dc855236e 100644 --- a/src/Shape.hs +++ b/src/Shape.hs @@ -15,8 +15,7 @@ module Shape , scaleSH , colorSH , overPosSH - ) - where + ) where import Geometry import Shape.Data import Color diff --git a/src/ShapePicture.hs b/src/ShapePicture.hs index 802f99899..0033054eb 100644 --- a/src/ShapePicture.hs +++ b/src/ShapePicture.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TupleSections #-} module ShapePicture ( emptyBlank , translateSPf @@ -8,8 +9,7 @@ module ShapePicture , noShape , _spShape , _spPicture - ) - where + ) where import Shape import Picture import Geometry @@ -18,11 +18,12 @@ import Data.Bifunctor type SPic = (Shape, Picture) +-- should all this be inlined/inlinable? noPic :: Shape -> SPic -noPic sh = (sh,mempty) +noPic = (,mempty) noShape :: Picture -> SPic -noShape pic = (mempty,pic) +noShape = (mempty,) _spShape :: SPic -> Shape _spShape = fst @@ -30,7 +31,7 @@ _spPicture :: SPic -> Picture _spPicture = snd emptyBlank :: SPic -emptyBlank = (emptySH,blank) +emptyBlank = mempty translateSPf :: Float -> Float -> SPic -> SPic translateSPf x y = bimap (translateSH (V3 x y 0)) (translate x y) diff --git a/src/Sound.hs b/src/Sound.hs index 799dbe9da..38459794a 100644 --- a/src/Sound.hs +++ b/src/Sound.hs @@ -118,14 +118,13 @@ cleanupHalted s = do ----------------------------------------------------------------- {- | Play sounds from a list of indices. For each index, the corresponding sound starts playing if there is a free channel. -Use this if you don't care about timing, overlapping, fading, or sound positions. --} +Use this if you don't care about timing, overlapping, fading, or sound positions. -} playSoundQueue :: IM.IntMap Mix.Chunk -> [Int] -> IO () -playSoundQueue chunkMap ns = forM_ ns $ \n -> runMaybeT $ playIfFree (chunkMap IM.! n) Mix.Once +--playSoundQueue chunkMap ns = forM_ ns $ \n -> runMaybeT $ playIfFree (chunkMap IM.! n) Mix.Once +playSoundQueue chunkMap = mapM_ $ \n -> runMaybeT $ playIfFree (chunkMap IM.! n) Mix.Once {- | Given a chunk, attempt to play this on a free channel a given number of -times. Returns 'Just' the channel if succeeds. --} +times. Returns 'Just' the channel if succeeds. -} playIfFree :: Mix.Chunk -> Mix.Times -> MaybeT IO Mix.Channel playIfFree c times = do i <- MaybeT $ Mix.getAvailable Mix.DefaultGroup @@ -133,8 +132,7 @@ playIfFree c times = do ----------------------------------------------------------------- {- | Play sounds from a list of index/position pairs. -As for 'playSoundQueue', but with positional information in the form of an Int16. --} +As for 'playSoundQueue', but with positional information in the form of an Int16. -} playPositionalSoundQueue :: IM.IntMap Mix.Chunk -> [(Int,Int16)] -> IO () playPositionalSoundQueue chunkMap = VS.mapM_ ( \(n,a) -> runMaybeT $ playIfFree (chunkMap IM.! n) Mix.Once >>= setChannelPos a ) @@ -146,13 +144,11 @@ setChannelPos a i = do return i ----------------------------------------------------------------- {- | Set the volume for all sound channels. -Behind the scenes, scales a float [0,1] to an Int [0..128]. - -} +Behind the scenes, scales a float [0,1] to an Int [0..128]. -} setSoundVolume :: Float -> IO () setSoundVolume x = Mix.setVolume (round (x * 128)) Mix.AllChannels {- | Set the music volume. -Behind the scenes, scales a float [0,1] to an Int [0..128]. - -} +Behind the scenes, scales a float [0,1] to an Int [0..128]. -} setMusicVolume :: Float -> IO () setMusicVolume x = Mix.setMusicVolume (round (x * 128)) diff --git a/src/StrictHelp.hs b/src/StrictHelp.hs index 31f5cdf36..34df1512e 100644 --- a/src/StrictHelp.hs +++ b/src/StrictHelp.hs @@ -1,5 +1,4 @@ -module StrictHelp - where +module StrictHelp where {- | In order to force a list, apply with seq. -} forceSpine :: Foldable t => t a -> () diff --git a/src/Tile.hs b/src/Tile.hs index 7bb521774..9c71e4359 100644 --- a/src/Tile.hs +++ b/src/Tile.hs @@ -10,19 +10,17 @@ tileToRenderList t = polyToTris $ zip ps3 coords3 where ps = _tilePoly t coords = map (calcTexCoord (_tileZero t) (_tileX t)) ps - ps3 = map (addToV2 0) ps - coords3 = map (addToV2 (_tileZ t)) coords - -addToV2 :: a -> V2 a -> V3 a -addToV2 z (V2 x y) = V3 x y z + ps3 = map (addZ 0) ps + coords3 = map (addZ (_tileZ t)) coords calcTexCoord :: Point2 -- ^ tile (0,0) -> Point2 -- ^ tile (1,0) -> Point2 -- ^ world point -> Point2 -calcTexCoord c p x = V2 (0.02 * dotV (p -.- c) xdir) (0.02 * dotV (p -.- c) ydir) +calcTexCoord c p x = V2 (vectorAmountIn xdir) (vectorAmountIn ydir) where + vectorAmountIn dir = 0.02 * dotV (p -.- c) dir xdir = x -.- c ydir = vNormal xdir diff --git a/test/Spec.hs b/test/Spec.hs index 903d23fcc..003e25247 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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)