99 lines
3.3 KiB
Haskell
99 lines
3.3 KiB
Haskell
{- Concerns link pairs of rooms.
|
|
Link pairs determine where rooms can attach to each other; each pair consists
|
|
of a position and a rotation.
|
|
The last link in the list is considered the incoming link, the other links are
|
|
the outgoing links. -}
|
|
module Dodge.Room.Link (
|
|
shiftRoomShiftToLink,
|
|
moveRoomBy,
|
|
shiftLinkBy,
|
|
doRoomShift,
|
|
shuffleLinks,
|
|
restrictRMInLinksPD,
|
|
) where
|
|
|
|
import Control.Lens
|
|
import qualified Data.Set as S
|
|
import Data.Tile
|
|
import Dodge.Data.GenWorld
|
|
import Dodge.Placement.Shift
|
|
import Dodge.RoomLink
|
|
import Dodge.ShiftPoint
|
|
import Geometry
|
|
import RandomHelp
|
|
import Data.Maybe
|
|
|
|
restrictRMInLinksPD :: ((Point2, Float) -> Bool) -> Room -> Room
|
|
restrictRMInLinksPD f = rmLinks %~ restrictLinkType InLink f
|
|
|
|
{- Shuffle the order of all links of a room randomly.
|
|
- Note this does not change their types. -}
|
|
shuffleLinks :: RandomGen g => Room -> State g Room
|
|
shuffleLinks = rmLinks %%~ shuffle
|
|
|
|
doRoomShift :: Room -> Room
|
|
doRoomShift rm = shiftRoomBy (_rmShift rm) rm & rmShift .~ _rmShift rm
|
|
|
|
-- NOTE placements, when placed, will be shifted by the value _rmShift
|
|
shiftRoomBy :: (Point2, Float) -> Room -> Room
|
|
shiftRoomBy shift r =
|
|
r
|
|
& rmPolys . each . each %~ shiftPointBy shift
|
|
& rmLinks . each %~ shiftLinkBy shift
|
|
& rmPath %~ S.map (shiftPathBy shift)
|
|
& rmBound . each . each %~ shiftPointBy shift
|
|
& rmShift %~ shiftPosDirBy shift
|
|
& rmFloor . tiles . each %~ shiftTile shift
|
|
& rmViewpoints . each %~ shiftPointBy shift
|
|
|
|
shiftTile :: Point2A -> Tile -> Tile
|
|
shiftTile shift tl = tl
|
|
& tilePoly . each %~ shiftPointBy shift
|
|
& tileZero %~ shiftPointBy s
|
|
& tileTangentPos %~ shiftPointBy s
|
|
where
|
|
s = fromMaybe shift $ tl ^. tileZeroShift
|
|
|
|
moveRoomBy :: (Point2, Float) -> Room -> Room
|
|
moveRoomBy shift r =
|
|
r
|
|
& rmPolys %~ fmap (map (shiftPointBy shift))
|
|
& rmLinks %~ fmap (shiftLinkBy shift)
|
|
& rmPath %~ S.map (shiftPathBy shift)
|
|
& rmBound %~ fmap (map (shiftPointBy shift))
|
|
& rmPmnts %~ map (shiftPlacement shift)
|
|
& rmFloor . tiles
|
|
%~ map
|
|
( (tilePoly %~ map (shiftPointBy shift))
|
|
. (tileZero %~ shiftPointBy shift)
|
|
. (tileTangentPos %~ shiftPointBy shift)
|
|
)
|
|
& rmViewpoints %~ map (shiftPointBy shift)
|
|
& rmPos %~ map ((rpPos %~ shiftPointBy shift) . (rpDir +~ snd shift))
|
|
|
|
shiftRoomShiftToLink :: (Point2, Float) -> (Point2, Float) -> Room -> Room
|
|
shiftRoomShiftToLink l inlink r =
|
|
shiftRoomShiftBy l
|
|
. shiftRoomShiftBy (0, pi - a)
|
|
$ shiftRoomShiftBy (- p, 0) r
|
|
where
|
|
(p, a) = inlink
|
|
|
|
-- NOTE placements, when placed, will be shifted by the value _rmShift
|
|
shiftRoomShiftBy :: (Point2, Float) -> Room -> Room
|
|
shiftRoomShiftBy shift = rmShift %~ shiftPosDirBy shift
|
|
|
|
shiftPosDirBy :: (Point2, Float) -> (Point2, Float) -> (Point2, Float)
|
|
shiftPosDirBy (pos, rot) (p, r) = (shiftPointBy (pos, rot) p, r + rot)
|
|
|
|
shiftLinkBy :: (Point2, Float) -> RoomLink -> RoomLink
|
|
shiftLinkBy (pos, rot) = overLnkPosDir f
|
|
where
|
|
f (p, r) = (shiftPointBy (pos, rot) p, r + rot)
|
|
|
|
shiftPathBy :: (Point2, Float) -> (Point2, Point2) -> (Point2, Point2)
|
|
shiftPathBy s (p1, p2) = sp1 `seq` sp2 `seq` (sp1, sp2)
|
|
where
|
|
sp1 = shiftPointBy s p1
|
|
sp2 = shiftPointBy s p2
|