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
package.yaml
+9 -4
View File
@@ -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
+17 -24
View File
@@ -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)
src/Dodge/Placement/Instance/Turret.hs
+1 -1
View File
@@ -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
+2 -1
View File
@@ -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
+2 -1
View File
@@ -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
+4 -2
View File
@@ -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
+5 -4
View File
@@ -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
src/Geometry/LHS.hs
+1 -1
View File
@@ -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
+1 -2
View File
@@ -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
+10
View File
@@ -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
+1 -2
View File
@@ -8,8 +8,7 @@ module Polyhedra
, boxXYZnobase
, polyToGeoRender
, polysToPic
)
where
) where
import Geometry
import Polyhedra.Data
import Picture.Data
src/Quaternion.hs
+1 -2
View File
@@ -1,7 +1,6 @@
module Quaternion
( rotateToZ
)
where
) where
import Geometry.Data
import Geometry.Vector3D
import qualified Linear.Quaternion as Q
src/Render.hs
+2 -2
View File
@@ -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
+1 -2
View File
@@ -15,8 +15,7 @@ module Shape
, scaleSH
, colorSH
, overPosSH
)
where
) where
import Geometry
import Shape.Data
import Color
src/ShapePicture.hs
+6 -5
View File
@@ -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
+7 -11
View File
@@ -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 -2
View File
@@ -1,5 +1,4 @@
module StrictHelp
where
module StrictHelp where
{- | In order to force a list, apply with seq. -}
forceSpine :: Foldable t => t a -> ()
src/Tile.hs
+4 -6
View File
@@ -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
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)