Attempt to improve perfomance

src/Dodge/Block.hs

@@ -65,11 +65,11 @@ destroyBlock bl w =
     ps = replicateM 25 (randInCirc 20) & evalState $ _randGen w
 
 -- this does not handle eg doors blocking the path as well
-maybeClearPaths :: Set (Int, Int, PathEdge) -> World -> World
+maybeClearPaths :: Set PathEdgeNodes -> World -> World
 maybeClearPaths ps w = foldl' maybeClearPath w ps
 
-maybeClearPath :: World -> (Int, Int, PathEdge) -> World
+maybeClearPath :: World -> PathEdgeNodes -> World
-maybeClearPath w (x, y, pe)
+maybeClearPath w (PathEdgeNodes x y pe)
     | not . null $ overlapSegWalls (_peStart pe) (_peEnd pe) $ wlsNearSeg (_peStart pe) (_peEnd pe) w =
         w
     | otherwise = w & cWorld . pathGraph %~ FGL.insEdge (x, y, pe & peObstacles .~ mempty) . FGL.delEdge (x, y)

src/Dodge/Concurrent.hs

@@ -1,22 +1,24 @@
 module Dodge.Concurrent where
 
-import Dodge.Data.Universe
 --import qualified Data.Set as S
 import Control.Lens
+import Dodge.Data.Universe
+
 --import Control.Concurrent
 --import SDL.Input.Keyboard.Codes
 
-conEffects :: Universe -> Maybe (Universe -> Universe,IO (Universe -> Maybe Universe))
+conEffects :: Universe -> ConcurrentEffect Universe
 conEffects u = case u ^. uvConcEffects of
-    NewConcEffect {_ceFunction = eff} -> Just eff
+    NewConcEffect{_ceFunction = eff} -> eff
-    _ -> Nothing
+    _ -> NoConcurrentEffect
 
 tryConcEffect :: Bool -> String -> IO (Universe -> Maybe Universe) -> Universe -> Universe
 tryConcEffect bl str eff u = case u ^. uvConcEffects of
-    NoConcEffect -> u & uvConcEffects .~ NewConcEffect (setstr, clearConcEff eff) str bl
+    NoConcEffect -> u & uvConcEffects .~ NewConcEffect (ConcurrentEffect setstr (clearConcEff eff)) str bl
     _ -> u
   where
-    setstr | bl = uvConcEffects .~ BlockingConcEffect str
+    setstr
+        | bl = uvConcEffects .~ BlockingConcEffect str
         | otherwise = uvConcEffects .~ BackgroundConcEffect str
 
 clearConcEff :: IO (Universe -> Maybe Universe) -> IO (Universe -> Maybe Universe)

src/Dodge/Data/Block.hs

@@ -31,7 +31,7 @@ data Block = Block
     , _blHeight :: Float
     , _blMaterial :: Material
     , _blDraw :: BlockDraw --Block -> SPic
-    , _blObstructs :: Set (Int, Int, PathEdge)
+    , _blObstructs :: Set PathEdgeNodes
     }
     deriving (Eq, Ord, Show, Read) --Generic, Flat)
 

src/Dodge/Data/CWorld.hs

@@ -178,7 +178,7 @@ data CWorld = CWorld
     , _pathGraph :: Gr Point2 PathEdge
     , _pnZoning :: IM.IntMap (IM.IntMap [(Int, Point2)]) --Zoning IM.IntMap Creature
     --, _peZoning :: IM.IntMap (IM.IntMap [(Int, Int, PathEdge)]) --Zoning IM.IntMap Creature
-    , _peZoning :: IM.IntMap (IM.IntMap (Set (Int, Int, PathEdge))) --Zoning IM.IntMap Creature
+    , _peZoning :: IM.IntMap (IM.IntMap (Set PathEdgeNodes))
     , _hud :: HUD
     , _lightSources :: IM.IntMap LightSource
     , _tempLightSources :: [TempLightSource]

src/Dodge/Data/Door.hs

@@ -46,7 +46,7 @@ data Door = Door
     , _drPushedBy :: PushSource
     , _drPushes :: Maybe Int
     , _drMounts :: [MountedObject]
-    , _drObstructs :: Set (Int, Int, PathEdge)
+    , _drObstructs :: Set PathEdgeNodes
     , _drObstacleType :: EdgeObstacle
     }
     --deriving (Eq, Ord, Show, Read) --Generic, Flat)

src/Dodge/Data/PathGraph.hs

@@ -26,7 +26,7 @@ data PathGraph = PathGraph
     { _pgGraph :: Gr Point2 PathEdge
     , _pgNodeMap :: Map Point2 Int
     , _pgNodeCount :: Int
-    , _pgEdgeMap :: Map (V2 Point2) (Int, Int, PathEdge)
+    , _pgEdgeMap :: Map (V2 Point2) PathEdgeNodes
     }
     deriving (Eq, Show, Read) --, Generic)
 

src/Dodge/Data/Universe.hs

@@ -9,8 +9,10 @@ module Dodge.Data.Universe (
     module Dodge.Data.World,
     module Data.Preload,
     module Picture.Data,
+    module Loop.Data
 ) where
 
+import Loop.Data
 import Control.Lens
 --import qualified Data.Map.Strict as M
 import Data.Preload
@@ -34,7 +36,7 @@ data Universe = Universe
     }
 
 data ConcEffect = NoConcEffect
-    | NewConcEffect {_ceFunction :: (Universe -> Universe, IO (Universe -> Maybe Universe))
+    | NewConcEffect {_ceFunction :: ConcurrentEffect Universe
         , _ceString :: String, _ceIsBlocking :: Bool}
     | BlockingConcEffect {_ceString :: String}
     | BackgroundConcEffect {_ceString :: String}

src/Dodge/Layout.hs

@@ -46,7 +46,7 @@ generateLevelFromRoomList gr' w =
             & cWorld . cwGen . cwgGameRooms .~ gameRoomsFromRooms (IM.elems rs')
             & cWorld . pathGraph .~ path
             & cWorld . pnZoning .~ foldl' (flip zonePn) mempty (labNodes path)
-            & cWorld . peZoning .~ foldl' (flip zonePe) mempty (labEdges path)
+            & cWorld . peZoning .~ foldl' (flip zonePe) mempty (map fromEdgeTuple $ labEdges path)
   where
     (_, path) = pairsToGraph pairPath'
     pairPath = foldMap _rmPath rs
@@ -54,6 +54,8 @@ generateLevelFromRoomList gr' w =
     rs = map doRoomShift $ IM.elems rs'
     rs' = mapM shuffleRoomPos gr' & evalState $ _randGen w
 
+fromEdgeTuple :: (Int,Int,PathEdge) -> PathEdgeNodes
+fromEdgeTuple (a,b,pe) = PathEdgeNodes a b pe
 
 randomCompass :: World -> World
 randomCompass w = w & cWorld . cwCam . cwcRot .~ (takeOne [0, 0.5 * pi, pi, 1.5 * pi] & evalState $ _randGen w)

src/Dodge/Layout.hs.orig

@@ -1,265 +0,0 @@
---{-# LANGUAGE TupleSections #-}
-module Dodge.Layout 
-    ( generateLevelFromRoomList
-    ) where
-import Data.Tile
-import Dodge.Data.GenWorld
-import Dodge.Path
-import Dodge.Zone.Update
-import Dodge.ShiftPoint
-import Dodge.Placement.PlaceSpot
-import Dodge.LevelGen.StaticWalls
-import Dodge.LevelGen.LevelStructure
-import Dodge.Wall.Zone
-import Dodge.GameRoom
-import Dodge.Default.Wall
-import Dodge.Room.Link
-import Dodge.Randify
-import Geometry
-import qualified IntMapHelp as IM
-import Tile
-import RandomHelp
-
-import Data.Graph.Inductive (labNodes,labEdges)
-import Data.List (nubBy)
-import Data.Traversable
-import Control.Lens
-import Data.Foldable
-import qualified Control.Foldl as L
-import Data.Maybe
-import Data.Function
-
-generateLevelFromRoomList :: IM.IntMap Room -> World -> World
-generateLevelFromRoomList gr' w = initWallZoning 
-    . randomCompass
-    . setupWorldBounds
-    . doAfterPlacements
-    . doInPlacements
-    . doOutPlacements
-    . doIndividualPlacements
-    . setFloors
-    . worldToGenWorld rs'
-    $ w { _walls        = wallsFromRooms rs
-        , _gameRooms    = gameRoomsFromRooms (IM.elems rs')
-        , _pathGraph    = path
-        , _pathGraphP   = pairPath
-        }
-        & pnZoning   %~ (\zn -> foldl' (flip $ updateZoning (:)) (zn & znObjects .~ mempty)
-<<<<<<< HEAD
-            (labNodes (_pgGraph path)))
-        & peZoning   %~ (\zn -> foldl' (flip $ updateZoning (:)) (zn & znObjects .~ mempty)
-            (labEdges (_pgGraph path)))
-  where
-    path = pairsToGraph pairPath
-=======
-            (labNodes path))
-        & peZoning   %~ (\zn -> foldl' (flip $ updateZoning (:)) (zn & znObjects .~ mempty)
-            (labEdges path))
-  where
-    (_,path) = pairsToGraph pairPath
->>>>>>> efficientRuntime
-    pairPath = foldMap _rmPath rs
-    rs = map doRoomShift $ IM.elems rs'
-    rs'= mapM shuffleRoomPos gr' & evalState $ _randGen w
-
-randomCompass :: World -> World
-randomCompass w = w & cameraRot .~ (takeOne [0,0.5*pi,pi,1.5*pi] & evalState $ _randGen w)
-
-putFloorTiles :: World -> World
-putFloorTiles gw = gw & floorTiles .~ floorsFromGenWorld gw
-
-setFloors :: World -> World
-setFloors = putFloorTiles . setTiles
-
--- note the order of traversal of the rooms is important
--- hence the reverse
--- this is not ideal: should do this in some more sensible way
-setTiles :: World -> World
-setTiles gw = foldr setTile gw . reverse . IM.elems $ _genRooms gw
-
-setTile :: Room -> World -> World
-setTile r gw = case _rmFloor r of
-    Tiled {} -> gw
-    InheritFloor -> gw & genRooms . ix (fromJust (_rmMID r)) . rmFloor .~ Tiled [t & tilePoly .~ poly]
-  where
-    t = case _rmMParent r of
-        Nothing -> Tile poly (V2 0 0) (V2 1 0) 16
-        Just pid -> head $ _tiles $ _rmFloor $ _genRooms gw IM.! pid
-    poly = orderPolygon . convexHullSafe . nubBy ((==) `on` roundPoint2) $ concat $ _rmPolys r
-
-shuffleRoomPos :: RandomGen g => Room -> State g Room
-shuffleRoomPos rm = do
-    newPos <- shuffle $ _rmPos rm
-    return $ rm & rmPos .~ newPos
-
-doAfterPlacements :: World -> World
-doAfterPlacements gw = foldr doAfterPlacement gw (_genPlacements gw)
-
-doAfterPlacement :: [(Placement,Int)] -> World -> World
-doAfterPlacement pmntis gw = gRandify gw $ do
-    (pmnt,i) <- takeOne pmntis
-    let (newgw,rm) = fst $ placeSpot (gw,_genRooms gw IM.! i) pmnt
-    return $ newgw & genRooms . ix i .~ rm
-
-doInPlacements :: ( IM.IntMap [Placement],World) -> World
-doInPlacements (im,w) = 
-    let (gw,rms) = mapAccumR (doRoomInPlacements im) w (_genRooms w)
-    in gw & genRooms .~ rms
-
-doRoomInPlacements :: IM.IntMap [Placement] -> World -> Room -> (World, Room)
-doRoomInPlacements im w rm = foldr f (w,rm) $ _rmInPmnt rm
-  where
-    f (InPlacement plf i) (w',r') = fst $ placeSpot (w',r') (plf $ im IM.! i)
-
-doOutPlacements :: World -> ( IM.IntMap [Placement], World)
-doOutPlacements w = let ((pmnts,gw),rms) = mapAccumR doRoomOutPlacements (IM.empty,w) (_genRooms w)
-    in (pmnts,gw & genRooms .~ rms)
-
-doRoomOutPlacements :: (IM.IntMap [Placement], World) 
-    -> Room 
-    -> ( (IM.IntMap [Placement], World) , Room )
-doRoomOutPlacements imw r = foldr f ( imw, r ) $ _rmOutPmnt r
-  where
-    f (OutPlacement pl i) ( (im,w) , rm ) = 
-        let ((neww,newrm),plmnts) = placeSpot (w,rm) pl
-        in ((IM.insert i plmnts im, neww) , newrm )
-
-doIndividualPlacements :: World -> World
-doIndividualPlacements gw = let (gw', rms) = mapAccumR doRoomPlacements gw (_genRooms gw)
-    in gw' & genRooms .~ rms
-
-doRoomPlacements :: World -> Room -> (World, Room)
-doRoomPlacements w rm = foldl' (\wr -> fst . placeSpot wr) (w,rm) $ _rmPmnts rm
-
-setupWorldBounds :: World -> World
-setupWorldBounds w = w & worldBounds %~
-    ( (bdMinX .~ f minx)
-    . (bdMaxX .~ f maxx)
-    . (bdMinY .~ f miny)
-    . (bdMaxY .~ f maxy)
-    )
-  where
-    f = fromMaybe 0
-    ps = IM.map (fst . _wlLine) $ _walls w
-    (minx,maxx,miny,maxy) = L.fold ((,,,) 
-        <$> L.premap fstV2 L.minimum
-        <*> L.premap fstV2 L.maximum
-        <*> L.premap sndV2 L.minimum
-        <*> L.premap sndV2 L.maximum
-        ) ps
-
---polyhedrasToEdges :: [Polyhedra] -> [Point3]
---polyhedrasToEdges = concatMap tflat4 . concatMap polyToEdges
-
-initWallZoning :: World -> World
-initWallZoning w = foldl' (flip insertWallInZones) (w & wlZoning . znObjects .~ IM.empty) (_walls w)
-
---makePath :: Tree Room -> [(Point2,Point2)]
---makePath = concatMap _rmPath . flatten
-
-wallsFromRooms :: [Room] -> IM.IntMap Wall
-wallsFromRooms = --    divideWalls .
-    IM.fromAscList 
-    . zipWith f [0..] 
-    . removeInverseWalls 
-    . foldl' (flip cutWalls) [] 
-    . concatMap _rmPolys
-  where
-    f i (x,y) = (i, defaultWall {_wlLine = (x,y) , _wlID = i})
-
--- TODO sort out shifting before or after etc
-gameRoomsFromRooms :: [Room] -> [GameRoom]
-gameRoomsFromRooms = fmap gameRoomFromRoom
-
-gameRoomFromRoom :: Room -> GameRoom
-gameRoomFromRoom rm = GameRoom
-    { _grViewpoints = map doshift $ _rmViewpoints rm ++ (map fst . foldl' (flip cutWalls) [] $ _rmPolys rm)
-        ++ mapMaybe filterUnusedLinks (_rmPos rm)
-    , _grViewpointsEx = concatMap filterUsedLinks (_rmPos rm)
-    , _grBound = map doshift $ expandPolyCorners 50 . convexHullSafe . nubBy closePoints 
-        . concat $ _rmBound rm ++ _rmPolys rm
-    , _grDir   = getDir $ _rmPos rm
-    , _grLinkDirs = mapMaybe undir $ _rmPos rm
-    , _grName  = _rmName rm
-    }
-  where
-    doshift = shiftPointBy (_rmShift rm)
-    doubleShift p a = map doshift
-        [p +.+ 10 *.* unitVectorAtAngle a
-        ,p -.- 10 *.* unitVectorAtAngle a
-        ]
-    filterUnusedLinks rp = case _rpLinkStatus rp of
-        UnusedLink{} -> Just $ _rpPos rp
-        _ -> Nothing
-    filterUsedLinks rp = case _rpLinkStatus rp of
-        UsedOutLink{} -> doubleShift (_rpPos rp) (_rpDir rp)
-        UsedInLink{} -> doubleShift (_rpPos rp) (_rpDir rp)
-        _ -> []
-    undir rp = case _rpLinkStatus rp of
-        UsedOutLink{} -> ma
-        UsedInLink{}  -> ma
-        _ -> Nothing
-      where
-        ma = Just $ 0.5*pi + _rpDir rp + snd (_rmShift rm)
-    closePoints x y = roundPoint2 x == roundPoint2 y
-    getDir (rp:xs) = case _rpLinkStatus rp of
-        UsedInLink {} -> _rpDir rp + snd (_rmShift rm)
-        _ -> getDir xs
-    getDir _ = 0 -- fallback
-
-floorsFromRooms :: [Room] -> [(Point3,Point3)]
-floorsFromRooms = concatMap (concatMap tileToRenderList . getTiles . _rmFloor . doRoomShift)
-
-floorsFromGenWorld :: World -> [(Point3,Point3)]
-floorsFromGenWorld = floorsFromRooms . IM.elems . _genRooms
-
-getTiles :: Floor -> [Tile]
-getTiles fl = case fl of
-    Tiled xs -> xs
-    _ -> error "tiles not correctly set for some room"
-
---divideWall :: Wall -> [Wall]
---divideWall wl
---    = let (a,b) = _wlLine wl
---          ps = divideLine (zoneSize * 2) a b
---      in  zipWith (\ x y -> wl & wlLine .~ (x,y) ) (init ps) (tail ps)
-
---divideWallIn :: Wall -> IM.IntMap Wall -> IM.IntMap Wall
---divideWallIn wl wls = 
---    let (wl':newWls) = divideWall wl
---        k = IM.newKey wls
---        newWls' = zipWith (\i w -> w {_wlID = i}) [k..] newWls
---    in  foldl' (flip $ \w -> IM.insert (_wlID w) w) wls (wl':newWls')
---
---divideWalls :: IM.IntMap Wall -> IM.IntMap Wall
---divideWalls wls = foldl' (flip divideWallIn) wls wls
-
---insertInZone :: Int -> Int -> a -> IM.IntMap (IM.IntMap a) -> IM.IntMap (IM.IntMap a)
---insertInZone x y obj = IM.insertWith f x $ IM.singleton y obj
---    where f _ = IM.insert y obj
-
---shiftRoomTree :: Tree Room -> Tree Room
---shiftRoomTree (Node t []) = Node t []
---shiftRoomTree (Node t ts) = Node t 
---    $ zipWith (\l -> shiftRoomTree . applyToRoot (shiftRoomToLink l)) 
---    (_rmLinks t) 
---    ts
-
---shiftRoomTreeConstruction :: Tree Room -> [Tree Room]
---shiftRoomTreeConstruction (Node t []) = [Node t []]
---shiftRoomTreeConstruction (Node t ts) = (Node t [] :) $ concat $
---    zipWith (\l -> shiftRoomTreeConstruction . applyToRoot (shiftRoomBy l . f)) 
---    (_rmLinks t) 
---    ts
---  where 
---    f r = shiftRoomBy ( V2 0 0 -.- rotateV (pi-a) p , 0) $ shiftRoomBy (V2 0 0,pi-a)  r
---      where 
---        (p,a) = last $ _rmLinks r
-
---addTile :: Float -> Room -> Room
---addTile z r
---    | not (null (_rmFloor r)) || null rp = r
---    | otherwise = r & rmFloor .~ [makeTileFromPoly poly z]
---  where
---    rp = _rmPolys r
---    poly = orderPolygon . convexHullSafe . nubBy ((==) `on` roundPoint2) $ concat rp

src/Dodge/LevelGen.hs

@@ -24,8 +24,8 @@ generateWorldFromSeed i = do
     writeFile "log/aGeneratedRoomLayout" ""
     generateGraphs
     (roomList, bounds) <- layoutLevelFromSeed 0 i
-    return $
+    return $!
-        postGenerationProcessing $
+        postGenerationProcessing $!
             _gwWorld (generateLevelFromRoomList roomList initialWorld{_randGen = mkStdGen i})
                 & cWorld . cwGen . cwgRoomClipping .~ bounds
                 & cWorld . cwGen . cwgSeed .~ i

src/Dodge/Path.hs

@@ -104,7 +104,7 @@ pointTowardsImpulse a b w = (find (flip (isWalkable a) w) . reverse) =<< makePat
 --        _  -> return $ Just $ ns !! i
 --
 
-pairsToGraph :: Set.Set (Point2, Point2) -> (Map (V2 Point2) (Int, Int, PathEdge), Gr Point2 PathEdge)
+pairsToGraph :: Set.Set (Point2, Point2) -> (Map (V2 Point2) PathEdgeNodes, Gr Point2 PathEdge)
 pairsToGraph pairs = addEdges nodemap gr pairs
   where
     (nodemap, _, gr) = addNodes $ Set.toList $ Set.map fst pairs <> Set.map snd pairs
@@ -120,27 +120,28 @@ addEdges ::
     Map Point2 Int ->
     Gr Point2 PathEdge ->
     Set.Set (Point2, Point2) ->
-    (Map (V2 Point2) (Int, Int, PathEdge), Gr Point2 PathEdge)
+    (Map (V2 Point2) PathEdgeNodes, Gr Point2 PathEdge)
 addEdges nodemap gr = foldl' f (mempty, gr)
   where
     f (edgemap, gr') (a, b) =
-        ( M.insert (V2 a b) theedge edgemap
+        ( M.insert (V2 a b) theedgedata edgemap
-        , insEdge theedge gr'
+        , insEdge theedgetup gr'
         )
       where
-        theedge = (g a, g b, PathEdge a b (dist a b) mempty)
+        theedgetup = (g a, g b, PathEdge a b (dist a b) mempty)
+        theedgedata = PathEdgeNodes (g a) (g b) (PathEdge a b (dist a b) mempty)
     g a = nodemap M.! a
 
-obstructPathsCrossing :: EdgeObstacle -> Point2 -> Point2 -> World -> (World, Set (Int, Int, PathEdge))
+obstructPathsCrossing :: EdgeObstacle -> Point2 -> Point2 -> World -> (World, Set PathEdgeNodes)
 obstructPathsCrossing obstacletype sp' ep w =
     ( w & cWorld . pathGraph %~ updateedges
     , es
     )
   where
     es = Set.filter edgecrosses $ pesNearSeg sp' ep w
-    edgecrosses (_, _, pe) = isJust $ intersectSegSeg sp' ep (_peStart pe) (_peEnd pe)
+    edgecrosses (PathEdgeNodes _ _ pe) = isJust $ intersectSegSeg sp' ep (_peStart pe) (_peEnd pe)
     updateedges gr = foldl' updateedge gr es
-    updateedge gr (x, y, pe) =
+    updateedge gr (PathEdgeNodes x y pe) =
         insEdge (x, y, pe & peObstacles . at obstacletype ?~ ()) $ delEdge (x, y) gr
 
 fuseFunc :: (a -> a -> Bool) -> [a] -> a -> a

src/Dodge/Placement/PlaceSpot/Block.hs

@@ -119,7 +119,7 @@ insertWalls blid wls w = w' & cWorld . blocks . ix blid . blObstructs .~ Set.uni
   where
     (w', paths) = mapAccumR (flip insertWall) w wls
 
-insertWall :: Wall -> World -> (World, Set (Int, Int, PathEdge))
+insertWall :: Wall -> World -> (World, Set PathEdgeNodes)
 insertWall wl =
     uncurry (obstructPathsCrossing BlockObstacle) (_wlLine wl)
         . (cWorld . walls . at (_wlID wl) ?~ wl)

src/Dodge/Placement/PlaceSpot/TriggerDoor.hs

@@ -65,11 +65,11 @@ addDoorWall eo drid wl w (wlid, wlps) =
   where
     (w', es) = uncurry (obstructPathsCrossing eo) wlps w
 
-maybeClearDoorPaths :: EdgeObstacle -> Set (Int, Int, PathEdge) -> World -> World
+maybeClearDoorPaths :: EdgeObstacle -> Set PathEdgeNodes -> World -> World
 maybeClearDoorPaths eo es w = foldl' (maybeClearDoorPath eo) w es
 
-maybeClearDoorPath :: EdgeObstacle -> World -> (Int, Int, PathEdge) -> World
+maybeClearDoorPath :: EdgeObstacle -> World -> PathEdgeNodes -> World
-maybeClearDoorPath eo w (x, y, pe)
+maybeClearDoorPath eo w (PathEdgeNodes x y pe)
     | not . null $ overlapSegWalls (_peStart pe) (_peEnd pe) $ wlsNearSeg (_peStart pe) (_peEnd pe) w =
         w & cWorld . pathGraph %~ FGL.insEdge (x, y, pe & peObstacles . at eo ?~ ()) . FGL.delEdge (x, y)
     | otherwise =

src/Dodge/Render/ShapePicture.hs

@@ -239,7 +239,7 @@ drawInspectWall w wl =
 drawDoorPaths :: World -> Int -> Picture
 drawDoorPaths w drid = fromMaybe mempty $ do
     paths <- w ^? cWorld . doors . ix drid . drObstructs
-    return $ foldMap (drawPathEdge . (^. _3)) paths
+    return $ foldMap' (drawPathEdge . (^. penPathEdge)) paths
 
 drawPathEdge :: PathEdge -> Picture
 drawPathEdge pe =

src/Dodge/Zoning/Pathing.hs

@@ -30,25 +30,25 @@ zoneOfPn = zoneOfPoint'' pnZoneSize . snd
 zonePn :: (Int, Point2) -> IM.IntMap (IM.IntMap [(Int, Point2)]) -> IM.IntMap (IM.IntMap [(Int, Point2)])
 zonePn pn = zoneMonoid (zoneOfPn pn) [pn]
 
-pesNearPoint :: Point2 -> World -> Set (Int, Int, PathEdge)
+pesNearPoint :: Point2 -> World -> Set PathEdgeNodes
 pesNearPoint p w = zoneExtract (zoneOfPoint peZoneSize p) (w ^. cWorld . peZoning)
 
-pesNearSeg :: Point2 -> Point2 -> World -> Set (Int, Int, PathEdge)
+pesNearSeg :: Point2 -> Point2 -> World -> Set PathEdgeNodes
 pesNearSeg sp ep w = zonesExtract (w ^. cWorld . peZoning) (zoneOfSeg peZoneSize sp ep)
 
-pesNearRect :: Point2 -> Point2 -> World -> Set (Int, Int, PathEdge)
+pesNearRect :: Point2 -> Point2 -> World -> Set PathEdgeNodes
 pesNearRect sp ep w = zonesExtract (w ^. cWorld . peZoning) $ zoneOfRect' peZoneSize sp ep
 
-pesNearCirc :: Point2 -> Float -> World -> Set (Int, Int, PathEdge)
+pesNearCirc :: Point2 -> Float -> World -> Set PathEdgeNodes
 pesNearCirc p r = pesNearRect (p +.+ V2 r r) (p -.- V2 r r)
 
 peZoneSize :: Float
 peZoneSize = 50
 
-zoneOfPe :: (Int, Int, PathEdge) -> [Int2]
+zoneOfPe :: (PathEdgeNodes) -> [Int2]
-zoneOfPe (_, _, pe) = zoneOfSeg peZoneSize (_peStart pe) (_peEnd pe)
+zoneOfPe (PathEdgeNodes _ _ pe) = zoneOfSeg peZoneSize (_peStart pe) (_peEnd pe)
 
-zonePe :: (Int, Int, PathEdge) -> IM.IntMap (IM.IntMap (Set (Int, Int, PathEdge))) -> IM.IntMap (IM.IntMap (Set (Int, Int, PathEdge)))
+zonePe :: PathEdgeNodes -> IM.IntMap (IM.IntMap (Set PathEdgeNodes)) -> IM.IntMap (IM.IntMap (Set (PathEdgeNodes)))
 zonePe pe im = foldl' f im (zoneOfPe pe)
   where
     f im' i2 = zoneMonoid i2 (Set.singleton pe) im'

src/Dodge/Zoning/Wall.hs

@@ -23,12 +23,14 @@ wlIXsNearCirc :: Point2 -> Float -> World -> IS.IntSet
 wlIXsNearCirc p r = wlIXsNearRect (p +.+ V2 r r) (p -.- V2 r r)
 
 wlsFromIXs :: World -> IS.IntSet -> [Wall]
+{-# INLINE wlsFromIXs #-}
 wlsFromIXs w = mapMaybe (\wlid -> w ^? cWorld . walls . ix wlid) . IS.toList
 
 wlsNearPoint :: Point2 -> World -> [Wall]
 wlsNearPoint p w = wlsFromIXs w $ wlIXsNearPoint p w
 
 wlsNearSeg :: Point2 -> Point2 -> World -> [Wall]
+{-# INLINE wlsNearSeg #-}
 wlsNearSeg sp ep w = wlsFromIXs w $ wlIXsNearSeg sp ep w
 
 wlsNearRect :: Point2 -> Point2 -> World -> [Wall]

src/Loop.hs

@@ -13,6 +13,7 @@ module Loop (
     setupConLoop,
 ) where
 
+import Loop.Data
 import Control.Concurrent
 import Control.Exception
 import Control.Monad
@@ -104,8 +105,9 @@ setupConLoop ::
     (world -> IO ()) ->
     -- | Initial simulation state.
     IO world ->
-    -- | Concurrent effects. Evaluating 'Nothing' exits the loop
+    ---- | Concurrent effects. Evaluating 'Nothing' exits the loop
-    (world -> Maybe (world -> world, IO (world -> Maybe world))) ->
+    --(world -> Maybe (world -> world, IO (world -> Maybe world))) ->
+    (world -> ConcurrentEffect world) ->
     -- | update, called once per frame. Allows for side effects such as rendering.
     (world -> IO world) ->
     -- | SDL Event handling, once per frame. Evaluating 'Nothing' exits the loop.
@@ -134,9 +136,10 @@ doConLoop ::
     Int ->
     -- | The SDL window.
     Window ->
-    -- | Concurrent effects, the first function in the pair is applied
+    ---- | Concurrent effects, the first function in the pair is applied
-    -- immediately
+    ---- immediately
-    (world -> Maybe (world -> world, IO (world -> Maybe world))) ->
+    --(world -> Maybe (world -> world, IO (world -> Maybe world))) ->
+    (world -> ConcurrentEffect world) ->
     -- | simulation update.
     (world -> IO world) ->
     -- | SDL Event handling.
@@ -150,13 +153,15 @@ doConLoop themvar spf window coneffs worldSideEffects eventFn !startWorld = go s
         startTicks <- ticks
         let mconeff = coneffs sw
         case mconeff of
-            Nothing -> return ()
+            NoConcurrentEffect -> return ()
-            Just (_, acc) -> do
+            ConcurrentEffect _ acc -> do
                 _ <- forkIO $ do
                     up <- acc
                     putMVar themvar up
                 return ()
-        let startWorld'' = maybe id fst mconeff sw
+        let startWorld'' = case mconeff of
+                NoConcurrentEffect -> sw
+                ConcurrentEffect immediatef _ -> immediatef sw
         mconupdate <- tryTakeMVar themvar
         let mstartWorld' = case mconupdate of
                 Just conupdate -> conupdate startWorld''

src/Shader/Poke.hs

@@ -4,7 +4,7 @@ module Shader.Poke
     , pokeLayVerxs
     , pokeArrayOff
 --    , pokePoint33s
-    , pokeShape
+--    , pokeShape
     , pokeShape'
     , pokeWallsWindowsFloor
     ) where