Hlinting
This commit is contained in:
@@ -28,9 +28,9 @@ makeButton c eff = Button
|
||||
--, _btText = "Button"
|
||||
, _btState = BtOff
|
||||
}
|
||||
where
|
||||
turnOn bt = bt {_btState = BtNoLabel, _btPict = onPict, _btEvent = (\_ -> id)}
|
||||
onPict = (onLayer WlLayer $ color c $ polygon $ rectNSEW (-3) (-5) 10 (-10))
|
||||
where
|
||||
turnOn bt = bt {_btState = BtNoLabel, _btPict = onPict, _btEvent = (\_ -> id)}
|
||||
onPict = onLayer WlLayer (color c $ polygon $ rectNSEW (-3) (-5) 10 (-10))
|
||||
|
||||
makeSwitch :: Color -> (World -> World) -> (World -> World) -> Button
|
||||
makeSwitch c effOn effOff = Button
|
||||
|
||||
@@ -23,47 +23,50 @@ import Data.Graph.Inductive.NodeMap
|
||||
-- probably don't have to rebuild the entire graph, oh well
|
||||
addButtonDoor :: Color -> Point2 -> Float -> Point2 -> Point2 -> World -> World
|
||||
addButtonDoor c btp btr a b w = over buttons (IM.insert bid bt)
|
||||
$ set pathPoints (foldr insertPoint IM.empty (labNodes newGraph))
|
||||
$ set pathGraph newGraph
|
||||
$ set pathGraph' newGraphPairs
|
||||
$ addTriggerDoor c cond a b w
|
||||
where bid = newKey $ _buttons w
|
||||
cond w = BtNoLabel == (_btState $ _buttons w IM.! bid)
|
||||
bt = (makeButton c eff) {_btPos = btp, _btRot = btr, _btID = bid}
|
||||
(newGraphPairs,removedPairs) = partition (not . isJust . uncurry (intersectSegSeg' a b))
|
||||
$ _pathGraph' w
|
||||
newGraph = pairsToGraph dist newGraphPairs
|
||||
insertPoint pp@(_,(x,y)) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp]
|
||||
eff w' = over pathGraph' (removedPairs ++)
|
||||
. over pathGraph (flip run_ $ insMapEdgesM $ map f removedPairs) $ w'
|
||||
f (x,y) = (x,y,dist x y)
|
||||
$ set pathPoints (foldr insertPoint IM.empty (labNodes newGraph))
|
||||
$ set pathGraph newGraph
|
||||
$ set pathGraph' newGraphPairs
|
||||
$ addTriggerDoor c cond a b w
|
||||
where
|
||||
bid = 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
|
||||
newGraph = pairsToGraph dist newGraphPairs
|
||||
insertPoint pp@(_,(x,y)) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp]
|
||||
eff w' = over pathGraph' (removedPairs ++)
|
||||
. over pathGraph (flip run_ $ insMapEdgesM $ map f removedPairs) $ w'
|
||||
f (x,y) = (x,y,dist x y)
|
||||
|
||||
addSwitchDoor :: Color -> Point2 -> Float -> Point2 -> Point2 -> World -> World
|
||||
addSwitchDoor c btp btr a b w = over buttons (IM.insert bid bt)
|
||||
$ set pathPoints (foldr insertPoint IM.empty (labNodes newGraph))
|
||||
$ set pathGraph newGraph
|
||||
$ set pathGraph' newGraphPairs
|
||||
$ addTriggerDoor c cond a b w
|
||||
where bid = 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 (not . isJust . uncurry (intersectSegSeg' a b))
|
||||
$ _pathGraph' w
|
||||
newGraph = pairsToGraph dist newGraphPairs
|
||||
insertPoint pp@(_,(x,y)) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp]
|
||||
openDoor w' = over pathGraph' (removedPairs ++)
|
||||
. over pathGraph (flip run_ $ insMapEdgesM $ map f removedPairs) $ w'
|
||||
f (x,y) = (x,y,dist x y)
|
||||
closeDoor w' = over pathGraph' (\pg -> pg \\ removedPairs)
|
||||
. over pathGraph (flip run_ $ delMapEdgesM removedPairs) $ w'
|
||||
$ set pathPoints (foldr insertPoint IM.empty (labNodes newGraph))
|
||||
$ set pathGraph newGraph
|
||||
$ set pathGraph' newGraphPairs
|
||||
$ addTriggerDoor c cond a b w
|
||||
where
|
||||
bid = 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
|
||||
newGraph = pairsToGraph dist newGraphPairs
|
||||
insertPoint pp@(_,(x,y)) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp]
|
||||
openDoor w' = over pathGraph' (removedPairs ++)
|
||||
. over pathGraph (flip run_ $ insMapEdgesM $ map f removedPairs) $ w'
|
||||
f (x,y) = (x,y,dist x y)
|
||||
closeDoor w' = over pathGraph' (\\ removedPairs)
|
||||
. over pathGraph (flip run_ $ delMapEdgesM removedPairs) $ w'
|
||||
|
||||
addTriggerDoor :: Color -> (World -> Bool) -> Point2 -> Point2 -> World -> World
|
||||
addTriggerDoor c cond a b = over walls (triggerDoor c cond a b)
|
||||
|
||||
triggerDoor :: Color -> (World -> Bool) -> Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap Wall
|
||||
triggerDoor c cond a b wls = IM.union wls $ IM.fromList $ zip is $ mkTriggerDoor c cond a b is
|
||||
where i = newKey wls
|
||||
is = [i..]
|
||||
where
|
||||
i = newKey wls
|
||||
is = [i..]
|
||||
|
||||
mkTriggerDoor :: Color -> (World -> Bool) -> Point2 -> Point2 -> [Int] -> [Wall]
|
||||
mkTriggerDoor c cond pl pr xs = addSound $ zipWith3 (triggerDoorPane c cond)
|
||||
@@ -100,7 +103,8 @@ mkTriggerDoor c cond pl pr xs = addSound $ zipWith3 (triggerDoorPane c cond)
|
||||
= soundFrom (WallSound (head xs)) (fromIntegral doorSound) 1 0
|
||||
$ dm w
|
||||
| otherwise = dm w
|
||||
where wp = (_wlLine $ _walls w IM.! (head xs)) !! 1
|
||||
where
|
||||
wp = _wlLine (_walls w IM.! (head xs)) !! 1
|
||||
|
||||
triggerDoorPane :: Color -> (World -> Bool) -> Int -> [Point2] -> [Point2] -> Wall
|
||||
triggerDoorPane c cond n closedPos openPos = Door
|
||||
@@ -113,22 +117,22 @@ triggerDoorPane c cond n closedPos openPos = Door
|
||||
, _wlIsSeeThrough = False
|
||||
, _doorPathable = False
|
||||
}
|
||||
where
|
||||
a = closedPos !! 0
|
||||
b = closedPos !! 1
|
||||
dm w | cond w = flip (foldr changeZonedWall) zoneps
|
||||
$ over walls (IM.adjust openDoor n) w -- . wlLine . ix 0) (mvPointToward a')
|
||||
| otherwise = flip (foldr changeZonedWall') zoneps
|
||||
$ over walls (IM.adjust closeDoor n) w -- . wlLine . ix 0) (mvPointToward a)
|
||||
zoneps | dist a b <= 2 * zoneSize = [zoneOfPoint $ pHalf a b]
|
||||
| otherwise = map zoneOfPoint $ divideLine (2*zoneSize) a b
|
||||
mvP !ep !p = mvPointTowardAtSpeed 2 ep p
|
||||
moveToward :: [Point2] -> Wall -> Wall
|
||||
moveToward !ps w = let !newPs = zipWith mvP ps $ _wlLine w
|
||||
in deepseq newPs $ w {_wlLine = newPs}
|
||||
openDoor = moveToward openPos
|
||||
closeDoor = moveToward closedPos
|
||||
changeZonedWall (!x,!y)
|
||||
= over wallsZone $ adjustIMZone openDoor x y n
|
||||
changeZonedWall' (!x,!y)
|
||||
= over wallsZone $ adjustIMZone closeDoor x y n
|
||||
where
|
||||
a = closedPos !! 0
|
||||
b = closedPos !! 1
|
||||
dm w | cond w = flip (foldr changeZonedWall) zoneps
|
||||
$ over walls (IM.adjust openDoor n) w -- . wlLine . ix 0) (mvPointToward a')
|
||||
| otherwise = flip (foldr changeZonedWall') zoneps
|
||||
$ over walls (IM.adjust closeDoor n) w -- . wlLine . ix 0) (mvPointToward a)
|
||||
zoneps | dist a b <= 2 * zoneSize = [zoneOfPoint $ pHalf a b]
|
||||
| otherwise = map zoneOfPoint $ divideLine (2*zoneSize) a b
|
||||
mvP !ep !p = mvPointTowardAtSpeed 2 ep p
|
||||
moveToward :: [Point2] -> Wall -> Wall
|
||||
moveToward !ps w = let !newPs = zipWith mvP ps $ _wlLine w
|
||||
in deepseq newPs $ w {_wlLine = newPs}
|
||||
openDoor = moveToward openPos
|
||||
closeDoor = moveToward closedPos
|
||||
changeZonedWall (!x,!y)
|
||||
= over wallsZone $ adjustIMZone openDoor x y n
|
||||
changeZonedWall' (!x,!y)
|
||||
= over wallsZone $ adjustIMZone closeDoor x y n
|
||||
|
||||
Reference in New Issue
Block a user