Improve intersection test--fails sometimes

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 $ intersectSegSegPreTest p1 p2)
-cutWallsPoints p1 p2 = mapMaybe (uncurry $ myIntersectSegSeg 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

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

@@ -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) 
+    go x a b (c:d:xs) = intersectSegSegTest a b c d || go x a b (d:xs)
-        | isJust $ myIntersectSegSeg a b c d = True
+    go d a b [c] = intersectSegSegTest a b c d
-        | otherwise = go x a b (d:xs)
-    go d a b [c] = isJust $ myIntersectSegSeg a b c d
     go _ _ _ _ = False
 pairPolyPointsIntersect _ _ _ = False
 

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

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 #-}

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
+    let wtex = fromIntegral $ imageWidth  tex
-        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