Improve level generation speed

src/Dodge/Creature/Inanimate.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE TupleSections #-}
+--{-# LANGUAGE TupleSections #-}
 {-
 Inanimate objects such as lamps, barrels, etc
 -}
@@ -17,11 +17,13 @@ import Dodge.WorldEvent.Sound
 import Dodge.Creature.Update hiding (CRUpdate)
 import Picture
 import qualified IntMapHelp as IM
-import Geometry.Data
+import Geometry
+--import Geometry.Data
 import Geometry.Vector3D
 import Polyhedra
 
 import Control.Lens
+import qualified Control.Foldl as L
 
 defaultInanimate :: Creature
 defaultInanimate = defaultCreature & crActionPlan .~ Inanimate
@@ -30,15 +32,30 @@ lamp :: Float -> Creature
 lamp h = defaultInanimate
     { _crUpdate = initialiseLamp h
     , _crHP = 100
-    , _crPict = picAtCrPos (lampPic h)
+    , _crPict = picAtCrPosNoRot (lampPic h)
     , _crRad = 3
     , _crMass = 3
     }
+-- it is not clear that any of the attempts with Foldl help at all here
 lampPic :: Float -> Picture
-lampPic h = pictures
-    [ setLayer 0 $ pictures . map (helpPoly3D . map ((, blue) . (-.-.- V3 2.5 2.5 0))) $ boxXYZ 5 5 (h-1)
-    , setLayer 1 $ setDepth h $ color white $ circleSolid 3
-    ]
+--{-# INLINE lampPic #-}
+lampPic h = setLayer 1 (setDepth h . color white $ circleSolid 3)
+     ++ (concatMap (preTriFold f) $ boxXYZnobase 5 5 (h-1))
+  where
+    f pos = Verx (pos -.-.- V3 2.5 2.5 0) blue [] 0 polyNum
+
+lTriFold :: a -> a -> L.Fold a [a]
+lTriFold s x = L.Fold (f s) (x,[]) snd
+  where
+    f s' (x1,l) x2 = (x2,s':x1:x2:l)
+
+preTriFold :: (a -> b) -> [a] -> [b]
+preTriFold f (s:x:xs) = L.fold (L.premap f $ lTriFold (f s) (f x)) xs
+preTriFold _ _ = []
+
+polyToTriFold :: [a] -> [a]
+polyToTriFold (s:x:xs) = L.fold (lTriFold s x) xs
+polyToTriFold _ = []
 
 initialiseLamp :: Float -> CRUpdate
 initialiseLamp h w (f,g) cr = ( (addLS . f , g), Just $ cr & crUpdate .~ updateLamp h i)

src/Dodge/Creature/Picture.hs

@@ -5,6 +5,7 @@ module Dodge.Creature.Picture
     ( basicCrPict
     , circLine
     , picAtCrPos
+    , picAtCrPosNoRot
     ) where
 import Dodge.Data
 --import Dodge.Creature.Stance.Data
@@ -174,5 +175,9 @@ circLine :: Float -> Picture
 circLine x = line [V2 0 0,V2 x 0]
 
 picAtCrPos :: Picture -> Creature -> World -> Picture
-{-# INLINE picAtCrPos #-}
-picAtCrPos thePic cr _ = uncurryV translate (_crPos cr) $ rotate (_crDir cr) thePic
+--{-# INLINE picAtCrPos #-}
+picAtCrPos thePic cr _ = tranRot (_crPos cr) (_crDir cr) thePic
+
+picAtCrPosNoRot :: Picture -> Creature -> World -> Picture
+--{-# INLINE picAtCrPos #-}
+picAtCrPosNoRot thePic cr _ = uncurryV translate (_crPos cr) thePic

src/Dodge/Debug.hs

@@ -2,6 +2,9 @@ module Dodge.Debug where
 import Dodge.Data
 import Dodge.Picture
 import Dodge.Picture.Layer
+import Dodge.Base.Zone
+import Dodge.Base
+import Geometry.Zone
 import Geometry.Data
 import Geometry
 import Picture
@@ -58,3 +61,14 @@ drawDDA = setLayer 1 . color (withAlpha 0.5 green) . IM.foldlWithKey' f []
       where
         x = 50 * fromIntegral x'
         ys = map ((50 *) . fromIntegral) $ IS.toList ys'
+
+debugWallZoningPic :: World -> Picture
+debugWallZoningPic w = setLayer 1 $ zonesPic ++ wallsPic
+  where
+    wallsPic = setDepth 25 . color yellow . concatMap (drawTheWall . _wlLine) $ IM.elems theWalls
+    drawTheWall (a,b) = lineOfThickness 20 [a,b]
+    theWalls = wallsAlongLine sp ep w
+    zonesPic = setDepth 20 $ drawDDA zones
+    zones = ddaExt zoneSize sp ep
+    sp = _crPos $ you w
+    ep = mouseWorldPos w

src/Dodge/Layout.hs

@@ -95,7 +95,7 @@ updateWallZoning w = set wallsZone (foldl' (flip wallInZone) IM.empty (_walls w)
       where 
         (x,y) = zoneOfPoint $ uncurry pHalf (_wlLine wl)
         wlid  = _wlID wl
-        ips = map zoneOfPoint $ uncurry (divideLine (zoneSize)) (_wlLine wl)
+        ips = map zoneOfPoint $ uncurry (divideLine zoneSize) (_wlLine wl)
 
 
 makePath :: Tree Room -> [(Point2,Point2)]

src/Dodge/LevelGen/StaticWalls.hs

@@ -6,11 +6,12 @@ module Dodge.LevelGen.StaticWalls
     where
 import Dodge.Data
 import Geometry
+import Geometry.ConvexPoly
 --import Geometry.Data
 import FoldableHelp
 
 --import Control.Lens
-import Data.List
+import Data.List.Extra
 import Data.Maybe
 import Data.Bifunctor
 -- | Describe a wall as two points.
@@ -119,26 +120,24 @@ checkWallLeft (x,y) wls
 -- Be aware that we do not remove all colinear walls; this may still cause bugs
 cutPoly :: [Point2] -> [WallP] -> [WallP]
 cutPoly qs wls = 
-    nub
+    nubOrd
     . removeInverseWalls
     . filter (not . wallIsZeroLength) 
     . fuseWallsWith zs
     . addPolyWalls rs  
---    . removeWallsInPolygon ps 
---    . filter (not.wallIsZeroLength) 
---    . fuseWallsWith zs
     $ removeWallsInPolygon ps 
      cwals
   where 
     (zs,cwals) = cutWallsWithPoints ps wls
     ps = orderPolygon qs
-    rs = orderPolygon $ nub $ zs ++ qs
+    rs = orderPolygon $ nubOrd $ zs ++ qs
 -- | Given a value and a poly, pushes the poly points out from the center by the
 -- value amount.
 expandPolyBy :: Float -> [Point2] -> [Point2]
 expandPolyBy x ps = map f ps
   where
-    cp = 1/fromIntegral (length ps) *.* foldr (+.+) (V2 0 0) ps
+    --cp = 1/fromIntegral (length ps) *.* foldl' (+.+) (V2 0 0) ps
+    cp = centroid ps
     f p = p +.+ x *.* (p -.- cp)
     --f p = p +.+ x *.* normalizeV (p -.- cp)
 -- | Given a polygon expressed as a list of points and a collection of walls,
@@ -146,10 +145,10 @@ expandPolyBy x ps = map f ps
 -- fst: points of the polygon's intersection with walls
 -- snd: the collection of walls after cutting by the polygon.
 cutWallsWithPoints :: [Point2] -> [WallP] -> ([Point2], [WallP] )
-cutWallsWithPoints (p:ps) ws = foldr f ([],ws) (zip (p:ps) (ps++[p]))
+cutWallsWithPoints (p:ps) ws = foldl' f ([],ws) (zip (p:ps) (ps++[p]))
   where 
-    f (p1,p2) (as,ws') = 
-        ( nub $ as ++ cutWallsPoints p1 p2 ws'
+    f (as,ws') (p1,p2) = 
+        ( nubOrd $ as ++ cutWallsPoints p1 p2 ws'
         , concatMap (cutWall p1 p2) ws'
         )
 cutWallsWithPoints _ _ = error "Trying to cut empty polygon"
@@ -167,7 +166,7 @@ addPolyWalls
     :: [Point2] -- ^ Multiple walls described as a polygon.
     -> [WallP] 
     -> [WallP]
-addPolyWalls (q:qs) wls = foldr addPolyWall wls (zip (q:qs) (qs++[q]))
+addPolyWalls (q:qs) wls = foldl' addPolyWall wls (zip (q:qs) (qs++[q]))
 addPolyWalls _ _ = error "Trying to add empty poly walls"
 -- | Add a new wall to a list of walls only if either
 -- 1. no wall already exists on the normal line from the new wall
@@ -175,8 +174,8 @@ addPolyWalls _ _ = error "Trying to add empty poly walls"
 -- face away from the new wall.
 -- The normal line is the line from the center point of the new wall outwards 
 -- along the clockwise normal of the new wall (currently 10000 units along)
-addPolyWall :: WallP -> [WallP] -> [WallP]
-addPolyWall (p1,p2) wls =
+addPolyWall :: [WallP] -> WallP -> [WallP]
+addPolyWall wls (p1,p2) =
     case maybeWs of 
         Just ws -> if uncurry isLHS ws p3
             then wls
@@ -213,9 +212,9 @@ fuseWall ps (x,y) = ( rs , (x',y') )
 -- | Given list of points and collection of walls, fuses the wall ends if
 -- they are close to the list of points or each other.
 fuseWallsWith :: [Point2] -> [WallP] -> [WallP]
-fuseWallsWith zs ws = snd $ foldr fuseWalls (zs, []) ws
+fuseWallsWith zs ws = snd $ foldl' fuseWalls (zs, []) ws
   where 
-    fuseWalls w (ps, ws') = 
+    fuseWalls (ps, ws') w = 
         let (qs, w') = fuseWall ps w
         in  (qs, w' :  ws')
 -- | Test if fst p == snd p.

src/Dodge/Render/Picture.hs

@@ -8,9 +8,9 @@ import Dodge.Picture
 import Dodge.Picture.Layer
 import Dodge.Render.HUD
 import Dodge.Render.MenuScreen
-import Dodge.Debug
+--import Dodge.Debug
 import Geometry
-import Geometry.Zone
+--import Geometry.Zone
 --import Geometry.Data
 import Picture
 import Polyhedra.Data
@@ -58,15 +58,7 @@ customMouseCursor w =
     $ pictures [ line [V2 (-5) 0,V2 5 0] , line [V2 0 (-5),V2 0 5] ]
 
 testPic :: World -> Picture
-testPic w = setLayer 1 $ zonesPic ++ wallsPic
-  where
-    wallsPic = setDepth 25 . color yellow . concatMap (drawTheWall . _wlLine) $ IM.elems theWalls
-    drawTheWall (a,b) = lineOfThickness 20 [a,b]
-    theWalls = wallsAlongLine sp ep w
-    zonesPic = setDepth 20 $ drawDDA zones
-    zones = ddaExt zoneSize sp ep
-    sp = _crPos $ you w
-    ep = mouseWorldPos w
+testPic _ = []
     
 --    [ setDepth (-1) . translate 0 0.8
 --        . scale 0.001 0.001 . text . show $ _crMvDir $ you w