Attempt to improve perfomance
This commit is contained in:
+3
-3
@@ -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 w (x, y, pe)
|
||||
maybeClearPath :: World -> PathEdgeNodes -> World
|
||||
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)
|
||||
|
||||
@@ -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
|
||||
_ -> Nothing
|
||||
NewConcEffect{_ceFunction = eff} -> eff
|
||||
_ -> 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)
|
||||
|
||||
@@ -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)
|
||||
|
||||
|
||||
@@ -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]
|
||||
|
||||
@@ -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)
|
||||
|
||||
@@ -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)
|
||||
|
||||
|
||||
@@ -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}
|
||||
|
||||
+3
-1
@@ -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)
|
||||
|
||||
@@ -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
|
||||
@@ -24,8 +24,8 @@ generateWorldFromSeed i = do
|
||||
writeFile "log/aGeneratedRoomLayout" ""
|
||||
generateGraphs
|
||||
(roomList, bounds) <- layoutLevelFromSeed 0 i
|
||||
return $
|
||||
postGenerationProcessing $
|
||||
return $!
|
||||
postGenerationProcessing $!
|
||||
_gwWorld (generateLevelFromRoomList roomList initialWorld{_randGen = mkStdGen i})
|
||||
& cWorld . cwGen . cwgRoomClipping .~ bounds
|
||||
& cWorld . cwGen . cwgSeed .~ i
|
||||
|
||||
+9
-8
@@ -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
|
||||
, insEdge theedge gr'
|
||||
( M.insert (V2 a b) theedgedata edgemap
|
||||
, 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
|
||||
|
||||
@@ -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)
|
||||
|
||||
@@ -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 eo w (x, y, pe)
|
||||
maybeClearDoorPath :: EdgeObstacle -> World -> PathEdgeNodes -> World
|
||||
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 =
|
||||
|
||||
@@ -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 =
|
||||
|
||||
@@ -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 (_, _, pe) = zoneOfSeg peZoneSize (_peStart pe) (_peEnd pe)
|
||||
zoneOfPe :: (PathEdgeNodes) -> [Int2]
|
||||
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'
|
||||
|
||||
@@ -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]
|
||||
|
||||
+13
-8
@@ -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
|
||||
(world -> Maybe (world -> world, IO (world -> Maybe world))) ->
|
||||
---- | Concurrent effects. Evaluating 'Nothing' exits the loop
|
||||
--(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
|
||||
-- immediately
|
||||
(world -> Maybe (world -> world, IO (world -> Maybe world))) ->
|
||||
---- | Concurrent effects, the first function in the pair is applied
|
||||
---- immediately
|
||||
--(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 ()
|
||||
Just (_, acc) -> do
|
||||
NoConcurrentEffect -> return ()
|
||||
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''
|
||||
|
||||
+1
-1
@@ -4,7 +4,7 @@ module Shader.Poke
|
||||
, pokeLayVerxs
|
||||
, pokeArrayOff
|
||||
-- , pokePoint33s
|
||||
, pokeShape
|
||||
-- , pokeShape
|
||||
, pokeShape'
|
||||
, pokeWallsWindowsFloor
|
||||
) where
|
||||
|
||||
Reference in New Issue
Block a user