Use tasty for tests, fix bug in circOnLine

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

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
+moveLaser :: Float    -- ^ Phase velocity, controls deflection through windows
-    :: 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
     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 (notseen 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) $ 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')
+    refract x y wl p 
-    h x y wl p 
+        | isEntering = p +.+ rotateV angleRef  (normalDist wlNormal)
-        | isEntering = p +.+ rotateV angleRef normalDist
+        | otherwise  = p +.+ rotateV angleRef' (normalDist wlNormal')
-        | otherwise = p +.+ rotateV angleRef' normalDist'
       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
+    notseen ws (_,Right wl) = not $ any (\w' -> _wlID w' == _wlID wl) ws
-    h' _ _ = True
+    notseen _ _ = True
-    (thHit, ps) = f [] pos xp
-    hitEffect = damThingHitWith (Lasering 19) pos xp thHit
     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)

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

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

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)

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)

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' 
+intersectSegSegTest x y z w
-    = f a' b' c' d' && f c' d' a' b'
+    = 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) ) 
+    f a b c d =  ( not (isRHS a b c) && not (isLHS a b d) ) 
-              || ( not (isLHS a b c) &&      isLHS a b d  )
+              || ( not (isLHS a b c) && not (isRHS a b d) )
 intersectSegSegPreTest
     :: Point2
     -> Point2

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. 

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

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)

src/Polyhedra.hs

@@ -8,8 +8,7 @@ module Polyhedra
     , boxXYZnobase
     , polyToGeoRender
     , polysToPic
-    )
+    ) where
-    where
 import Geometry
 import Polyhedra.Data
 import Picture.Data

src/Quaternion.hs

@@ -1,7 +1,6 @@
 module Quaternion
     ( rotateToZ
-    )
+    ) where
-    where
 import Geometry.Data
 import Geometry.Vector3D
 import qualified Linear.Quaternion as Q

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

src/Shape.hs

@@ -15,8 +15,7 @@ module Shape
     , scaleSH
     , colorSH
     , overPosSH
-    )
+    ) where
-  where
 import Geometry
 import Shape.Data
 import Color

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)

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))

src/StrictHelp.hs

@@ -1,5 +1,4 @@
-module StrictHelp
+module StrictHelp where
-    where
 
 {- | In order to force a list, apply with seq. -}
 forceSpine :: Foldable t => t a -> ()

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
+    ps3 = map (addZ 0) ps
-    coords3 = map (addToV2 (_tileZ t)) coords
+    coords3 = map (addZ (_tileZ t)) coords
-
-addToV2 :: a -> V2 a -> V3 a
-addToV2 z (V2 x y) = V3 x y z
 
 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
 

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
+main = defaultMain $
-    putStrLn "Running tests:"
+    testGroup "Tests"
-    quickCheck prop_looping
+        [testGroup "Geometry tests" geometryTests]
 
-nextPair :: Eq a => (a,a) -> [(a,a)] -> [(a,a)]
+geometryTests =
-nextPair (_,y) = filter (\(x,_) -> x == y)
+    [ 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
+--nextPair :: Eq a => (a,a) -> [(a,a)] -> [(a,a)]
-isLooping xs = all (( == 1) . length . flip nextPair xs) xs
+--nextPair (_,y) = filter (\(x,_) -> x == y)
-
+--
-isLooping' :: Eq a => [(a,a)] -> Bool
+--isLooping :: Eq a => [(a,a)] -> Bool
-isLooping' xs = all (f xs) xs
+--isLooping xs = all (( == 1) . length . flip nextPair xs) xs
-  where
+--
-    f ys (x,y) = length ins == length outs && length rins == length routs
+--isLooping' :: Eq a => [(a,a)] -> Bool
-      where
+--isLooping' xs = all (f xs) xs
-        ins = filter (\(a,b) -> a == x) ys
+--  where
-        outs = filter (\(a,b) -> b == x) ys
+--    f ys (x,y) = length ins == length outs && length rins == length routs
-        rins = filter (\(a,b) -> a == y) ys
+--      where
-        routs = filter (\(a,b) -> b == y) ys
+--        ins = filter (\(a,b) -> a == x) ys
-
+--        outs = filter (\(a,b) -> b == x) ys
-polygonStrictlyConvex :: [Point2] -> Bool
+--        rins = filter (\(a,b) -> a == y) ys
-polygonStrictlyConvex ps = True
+--        routs = filter (\(a,b) -> b == y) ys
-
+--
---prop_looping :: [Point2] -> [WallP] -> Bool
+--polygonStrictlyConvex :: [Point2] -> Bool
-
+--polygonStrictlyConvex ps = True
-prop_looping = forAllShrink genTris shrinkTris $ \tris ->
+--
-    not (any ( \[a,b,c] -> isOnSeg a b c
+--
-                            || isOnSeg a c b
+--shrinkTris [] = []
-                            || isOnSeg b c a
+--shrinkTris (x:xs) = xs : map (x :) (shrinkTris xs)
-                ) tris)
+--
-    ==> isLooping' (foldr cutWalls' [] tris)
+--genTri = zip <$> trip <*> trip 
-
+--  where
-shrinkTris [] = []
+--    trip = vectorOf 3 $ fromIntegral <$> choose (0,3::Int)
-shrinkTris (x:xs) = xs : map (x :) (shrinkTris xs)
+--
-
+--genTris = listOf genTri
-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)