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

Improve intersection test--fails sometimes

Browse Source
This commit is contained in:
jgk
2021-08-17 00:52:54 +02:00
parent 650e58bdfa
commit 5da577ff12
6 changed files with 68 additions and 24 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/LevelGen/StaticWalls.hs
+8 -5
View File
@@ -1,3 +1,4 @@
{-# LANGUAGE TupleSections #-}
{-|
Module : Dodge.LevelGen.StaticWalls
Description : Concerns carving out of static walls to create the general room plan of the level.
@@ -154,11 +155,10 @@ cutWallsWithPoints (p:ps) ws = foldl' f ([],ws) (zip (p:ps) (ps++[p]))
cutWallsWithPoints _ _ = error "Trying to cut empty polygon"
-- | List the points of intersection between a segment and collection of walls.
cutWallsPoints :: Point2 -> Point2 -> [WallP] -> [Point2]
--cutWallsPoints p1 p2 ws = mapMaybe (\(x:y:_) -> intersectExtendedSegSeg p1 p2 x y)
cutWallsPoints p1 p2 = mapMaybe (uncurry $ myIntersectSegSeg p1 p2)
cutWallsPoints p1 p2 = mapMaybe (uncurry $ intersectSegSegPreTest p1 p2)
-- | Given a segment and a wall, split the wall into two if it crosses the segment.
cutWall :: Point2 -> Point2 -> WallP -> [WallP]
cutWall p1 p2 (x,y) = case myIntersectSegSeg p1 p2 x y of
cutWall p1 p2 (x,y) = case intersectSegSegPreTest p1 p2 x y of
Nothing -> [(x,y)]
Just cp -> [(x,cp),(cp,y)]
-- | Add poly walls?
@@ -182,10 +182,13 @@ addPolyWall wls (p1,p2) =
else (p1,p2) : wls
Nothing -> (p1,p2) : wls
where
maybeWs = safeMinimumOn (dist p3 . fromJust . f) $ filter (isJust . f) wls
--maybeWs = safeMinimumOn (dist p3 . fromJust . f) $ filter (isJust . f) wls
--maybeWs = fmap fst $ safeMinimumOn (dist p3 . snd) $ mapMaybe (\x -> (x,) <$> f x) wls
maybeWs = safeMinimumOnMaybe (fmap (dist p3) . f) wls
p3 = 0.5 *.* (p1 +.+ p2)
p4 = p3 +.+ 10000 *.* vNormal (p2 -.- p1)
f = uncurry $ myIntersectSegSeg p3 p4
f = uncurry $ intersectSegSegPreTest p3 p4
--g = uncurry $ intersectSegSegTest p3 p4
-- | Given a list of points and a point, returns a point in the list if any is close
-- to the point.
findClosePoint :: [Point2] -> Point2 -> Maybe Point2
src/FoldableHelp.hs
+12 -1
View File
@@ -1,5 +1,7 @@
{-# LANGUAGE TupleSections #-}
module FoldableHelp
( safeMinimumOn
, safeMinimumOnMaybe
, module Data.Foldable
)
where
@@ -7,17 +9,26 @@ import Data.Foldable
-- TODO check up whether and how it is necessary to specialise this
-- | A version of 'minimum' where the comparison is done on some extracted value.
-- Returns Nothing if the list is empty. Only calls the function once per element.
-- Returns Nothing if the list is empty. Only calls the function once per element (not true).
--
-- > safeMinimumOn id [] == Nothing
-- > safeMinimumOn length ["test","extra","a"] == Just "a"
safeMinimumOn :: (Foldable t,Ord b) => (a -> b) -> t a -> Maybe a
{-# INLINE safeMinimumOn #-}
safeMinimumOn f = foldl' g Nothing
where
g (Just x) y
| f x < f y = Just x
| otherwise = Just y
g Nothing y = Just y
safeMinimumOnMaybe :: (Ord b) => (a -> Maybe b) -> [a] -> Maybe a
safeMinimumOnMaybe f ys = fst <$> go Nothing ys
where
go Nothing (x:xs) = go ((x ,) <$> f x) xs
go (Just (y,cmin)) (x:xs) = case f x of
Just v | v < cmin -> go (Just (x,v)) xs
_ -> go (Just (y,cmin)) xs
go m _ = m
--{- | Partial. -}
--minimumOn :: Ord b => (a -> b) -> [a] -> a
--minimumOn f [] = error "tried to take minimumOn of empty list"
src/Geometry/ConvexPoly.hs
+2 -6
View File
@@ -14,7 +14,6 @@ import Geometry.Vector
import Geometry.LHS
import Geometry.Intersect
import Data.Maybe
import Control.Lens
import qualified Control.Foldl as L
data ConvexPoly = ConvexPoly
@@ -30,7 +29,6 @@ pointsToPoly xs = ConvexPoly
}
where
cen = centroid xs
-- | Test whether two polygons intersect or if one is contained in the other.
convexPolysOverlap :: ConvexPoly -> ConvexPoly -> Bool
convexPolysOverlap cp1 cp2 = dist (_cpCen cp1) (_cpCen cp2) < _cpRad cp1 + _cpRad cp2
@@ -64,10 +62,8 @@ polyPointsIntersect _ _ = False
pairPolyPointsIntersect :: Point2 -> Point2 -> [Point2] -> Bool
pairPolyPointsIntersect a' b' (c':d':xs') = go c' a' b' (c':d':xs')
where
go x a b (c:d:xs)
| isJust $ myIntersectSegSeg a b c d = True
| otherwise = go x a b (d:xs)
go d a b [c] = isJust $ myIntersectSegSeg a b c d
go x a b (c:d:xs) = intersectSegSegTest a b c d || go x a b (d:xs)
go d a b [c] = intersectSegSegTest a b c d
go _ _ _ _ = False
pairPolyPointsIntersect _ _ _ = False
src/Geometry/Intersect.hs
+25
View File
@@ -5,6 +5,7 @@ Testing for and finding intersection points.
module Geometry.Intersect
where
import Geometry.Data
import Geometry.LHS
import Control.Applicative
import Data.Maybe (isNothing)
@@ -74,6 +75,30 @@ intersectSegLine' (V2 x1 y1) (V2 x2 y2) (V2 x3 y3) (V2 x4 y4)
den = (x1-x2)*(y3-y4) - (y1-y2)*(x3-x4)
t' = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4)
--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.
intersectSegSegTest
:: Point2
-> Point2
-> Point2
-> Point2
-> Bool
{-# INLINE intersectSegSegTest #-}
intersectSegSegTest a' b' c' d'
= f a' b' c' d' && f c' d' a' b'
where
f a b c d = ( isLHS a b c && not (isLHS a b d) )
|| ( not (isLHS a b c) && isLHS a b d )
intersectSegSegPreTest
:: Point2
-> Point2
-> Point2
-> Point2
-> Maybe Point2
{-# INLINE intersectSegSegPreTest #-}
intersectSegSegPreTest a b c d
| intersectSegSegTest a b c d = myIntersectSegSeg a b c d
| otherwise = Nothing
-- | Due to floating point issues, 'intersectSegSeg'' is not always
-- accurate---'myIntersectSegSeg'
-- fixes at least some of
src/Picture.hs
+3 -3
View File
@@ -72,9 +72,9 @@ blank = []
polygon :: [Point2] -> Picture
{-# INLINE polygon #-}
polygon ps = map (f . zeroZ) $ polyToTris ps
polygon ps = map f $ polyToTris ps
where
f pos = Verx pos black [] 0 polyNum
f (V2 x y) = Verx (V3 x y 0) black [] 0 polyNum
polygonZ :: [Point2] -> Float -> Picture
{-# INLINE polygonZ #-}
@@ -191,7 +191,7 @@ scale3 a b (V3 x y z) = V3 (x*a) (y*b) z
scale :: Float -> Float -> Picture -> Picture
{-# INLINE scale #-}
--scale x y = map . second . overPos $ scale3 x y
scale x y = map $ overPos $ scale3 x y
scale x = map . overPos . scale3 x
rotate :: Float -> Picture -> Picture
{-# INLINE rotate #-}
src/Shader/AuxAddition.hs
+16 -7
View File
@@ -25,11 +25,10 @@ addTexture texturePath shad = do
let tex = convertRGBA8 cmap
textureOb <- genObjectName
textureBinding Texture2D $= Just textureOb
let texData = V.toList $ imageData tex
wtex = fromIntegral $ imageWidth tex
let wtex = fromIntegral $ imageWidth tex
htex = fromIntegral $ imageHeight tex
glTexStorage2D GL_TEXTURE_2D 3 GL_RGBA8 wtex htex
withArray texData $ \ptr -> do
V.unsafeWith (imageData tex) $ \ptr -> do
glTexSubImage2D GL_TEXTURE_2D 0 0 0 wtex htex GL_RGBA GL_UNSIGNED_BYTE ptr
textureFilter Texture2DArray $= ((Linear',Just Linear') , Linear')
generateMipmap' Texture2D
@@ -46,7 +45,8 @@ vaddTextureNoFilter texturePath shad = do
wtex = fromIntegral $ imageWidth tex
htex = fromIntegral $ imageHeight tex
glTexStorage2D GL_TEXTURE_2D 1 GL_RGBA8 wtex htex
withArray texData $ \ptr -> do
--withArray texData $ \ptr -> do
V.unsafeWith (imageData tex) $ \ptr -> do
glTexSubImage2D GL_TEXTURE_2D 0 0 0 wtex htex GL_RGBA GL_UNSIGNED_BYTE ptr
return $ shad & shaderTexture ?~ ShaderTexture {_textureObject = textureOb}
@@ -61,20 +61,22 @@ addTextureNoFilter texturePath shad = do
wtex = fromIntegral $ imageWidth tex
htex = fromIntegral $ imageHeight tex
glTexStorage2D GL_TEXTURE_2D 1 GL_RGBA8 wtex htex
withArray texData $ \ptr -> do
--withArray texData $ \ptr -> do
V.unsafeWith (imageData tex) $ \ptr -> do
glTexSubImage2D GL_TEXTURE_2D 0 0 0 wtex htex GL_RGBA GL_UNSIGNED_BYTE ptr
return $ shad & shaderTexture ?~ ShaderTexture {_textureObject = textureOb}
addTextureArray :: String -> FullShader -> IO FullShader
addTextureArray texturePath shad = do
Right cmap <- readImage texturePath
let tex = convertRGBA8 cmap
textureOb <- genObjectName
textureBinding Texture2DArray $= Just textureOb
Right cmap <- readImage texturePath
let tex = convertRGBA8 cmap
let texData = tilesToLine 128 8 .
V.toList $ imageData tex
glTexStorage3D GL_TEXTURE_2D_ARRAY 3 GL_RGBA8 32 32 64
withArray texData $ \ptr -> do
--glTexSubImage3D GL_TEXTURE_2D_ARRAY 0 0 0 0 32 32 64 GL_RGBA GL_UNSIGNED_BYTE ptr
glTexSubImage3D GL_TEXTURE_2D_ARRAY 0 0 0 0 32 32 64 GL_RGBA GL_UNSIGNED_BYTE ptr
textureFilter Texture2DArray $= ((Linear',Just Linear') , Linear')
generateMipmap' Texture2DArray
@@ -87,6 +89,13 @@ tilesToLine
-> [a]
-> [a]
tilesToLine w n = concat . concat . transpose . chunksOf n . chunksOf w
tilesToLineV
:: Int -- ^ Parameter a
-> Int -- ^ Parameter b
-> V.Vector a
-> V.Vector a
tilesToLineV w n = undefined
addUniforms :: [String] -> FullShader -> IO FullShader
addUniforms uniStrings shad = do