Add quicksave

This commit is contained in:
2021-09-13 00:17:45 +01:00
parent 064d43f903
commit 49274064a0
11 changed files with 28 additions and 18 deletions
+2 -2
View File
@@ -19,10 +19,10 @@ pairsToGraph f pairs =
in undir $ run_ Data.Graph.Inductive.empty $ insMapNodesM nodes' >> insMapEdgesM pairs'
removePathsCrossing :: Point2 -> Point2 -> World -> World
removePathsCrossing a b w = set pathGraph newGraph $ set pathGraph' pg'
removePathsCrossing a b w = set pathGraph newGraph $ set pathGraphP pg'
$ set pathPoints (foldr insertPoint IM.empty (labNodes newGraph))
w
where
pg' = filter (isNothing . uncurry (intersectSegSeg a b)) $ _pathGraph' w
pg' = filter (isNothing . uncurry (intersectSegSeg a b)) $ _pathGraphP w
insertPoint pp@(_,V2 x y) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp]
newGraph = pairsToGraph dist pg'
+7 -7
View File
@@ -29,17 +29,17 @@ addButtonDoor c btp btr a b speed w
= over buttons (IM.insert bid bt)
$ set pathPoints (foldr insertPoint IM.empty (labNodes newGraph))
$ set pathGraph newGraph
$ set pathGraph' newGraphPairs
$ set pathGraphP newGraphPairs
$ putDoubleDoor c cond a b speed w
where
bid = IM.newKey $ _buttons w
cond w' = BtNoLabel == _btState (_buttons w' IM.! bid)
bt = (makeButton c eff) {_btPos = btp, _btRot = btr, _btID = bid}
(newGraphPairs,removedPairs) = partition (isNothing . uncurry (intersectSegSeg a b))
$ _pathGraph' w
$ _pathGraphP w
newGraph = pairsToGraph dist newGraphPairs
insertPoint pp@(_,V2 x y) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp]
eff w' = over pathGraph' (removedPairs ++)
eff w' = over pathGraphP (removedPairs ++)
. over pathGraph (flip run_ $ insMapEdgesM $ map f removedPairs) $ w'
f (x,y) = (x,y,dist x y)
-- this has been repeated at least three times: TO BE UNIFIED, REFACTORED
@@ -47,20 +47,20 @@ addSwitchDoor :: Color -> Point2 -> Float -> Point2 -> Point2 -> Float -> World
addSwitchDoor c btp btr a b speed w = over buttons (IM.insert bid bt)
$ set pathPoints (foldr insertPoint IM.empty (labNodes newGraph))
$ set pathGraph newGraph
$ set pathGraph' newGraphPairs
$ set pathGraphP newGraphPairs
$ putDoubleDoor c cond a b speed w
where
bid = IM.newKey $ _buttons w
cond w' = BtOn == _btState (_buttons w' IM.! bid)
bt = (makeSwitch c openDoor closeDoor) {_btPos = btp, _btRot = btr, _btID = bid}
(newGraphPairs,removedPairs) = partition (isNothing . uncurry (intersectSegSeg a b))
$ _pathGraph' w
$ _pathGraphP w
newGraph = pairsToGraph dist newGraphPairs
insertPoint pp@(_,V2 x y) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp]
openDoor w' = over pathGraph' (removedPairs ++)
openDoor w' = over pathGraphP (removedPairs ++)
. over pathGraph (flip run_ $ insMapEdgesM $ map f removedPairs) $ w'
f (x,y) = (x,y,dist x y)
closeDoor w' = over pathGraph' (\\ removedPairs)
closeDoor w' = over pathGraphP (\\ removedPairs)
. over pathGraph (flip run_ $ delMapEdgesM removedPairs) $ w'
putDoor