From 5da577ff1236666d90f933acceac8679ec9f14b9 Mon Sep 17 00:00:00 2001 From: jgk Date: Tue, 17 Aug 2021 00:52:54 +0200 Subject: [PATCH] Improve intersection test--fails sometimes --- src/Dodge/LevelGen/StaticWalls.hs | 13 ++++++++----- src/FoldableHelp.hs | 13 ++++++++++++- src/Geometry/ConvexPoly.hs | 12 ++++-------- src/Geometry/Intersect.hs | 25 +++++++++++++++++++++++++ src/Picture.hs | 6 +++--- src/Shader/AuxAddition.hs | 23 ++++++++++++++++------- 6 files changed, 68 insertions(+), 24 deletions(-) diff --git a/src/Dodge/LevelGen/StaticWalls.hs b/src/Dodge/LevelGen/StaticWalls.hs index 33d646aa8..f7da925b2 100644 --- a/src/Dodge/LevelGen/StaticWalls.hs +++ b/src/Dodge/LevelGen/StaticWalls.hs @@ -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 diff --git a/src/FoldableHelp.hs b/src/FoldableHelp.hs index b0ba71c84..950f7b378 100644 --- a/src/FoldableHelp.hs +++ b/src/FoldableHelp.hs @@ -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" diff --git a/src/Geometry/ConvexPoly.hs b/src/Geometry/ConvexPoly.hs index 0a6269dfa..14e947281 100644 --- a/src/Geometry/ConvexPoly.hs +++ b/src/Geometry/ConvexPoly.hs @@ -14,23 +14,21 @@ import Geometry.Vector import Geometry.LHS import Geometry.Intersect -import Data.Maybe import Control.Lens import qualified Control.Foldl as L data ConvexPoly = ConvexPoly { _cpPoints :: [Point2] - , _cpCen :: Point2 + , _cpCen :: Point2 , _cpRad :: Float } pointsToPoly :: [Point2] -> ConvexPoly pointsToPoly xs = ConvexPoly { _cpPoints = xs - , _cpCen = cen + , _cpCen = cen , _cpRad = minimum $ map (dist cen) xs } 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 diff --git a/src/Geometry/Intersect.hs b/src/Geometry/Intersect.hs index 278309ae4..7221ccf63 100644 --- a/src/Geometry/Intersect.hs +++ b/src/Geometry/Intersect.hs @@ -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 diff --git a/src/Picture.hs b/src/Picture.hs index bc59ea78c..af353c31b 100644 --- a/src/Picture.hs +++ b/src/Picture.hs @@ -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 #-} diff --git a/src/Shader/AuxAddition.hs b/src/Shader/AuxAddition.hs index c2c48f14b..acf83fa94 100644 --- a/src/Shader/AuxAddition.hs +++ b/src/Shader/AuxAddition.hs @@ -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