183 lines
6.5 KiB
Haskell
183 lines
6.5 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
|
|
, shiftRoomBy
|
|
, moveRoomBy
|
|
, shiftLinkBy
|
|
, doRoomShift
|
|
, sortOutLinksOn
|
|
, filterSortOutLinksOn
|
|
, randomiseAllLinks
|
|
, shuffleLinks
|
|
, filterLinks
|
|
, changeLinkTo
|
|
, changeLinkFrom
|
|
, randomiseOutLinks
|
|
, chooseOneInLink
|
|
, restrictRMInLinksPD
|
|
) where
|
|
import Dodge.ShiftPoint
|
|
--import Dodge.Placement.PlaceSpot
|
|
import Dodge.Placement.Shift
|
|
import Dodge.LevelGen.Data
|
|
import Dodge.RandomHelp
|
|
import Geometry
|
|
import Data.Tile
|
|
import Dodge.RoomLink
|
|
|
|
import System.Random
|
|
import Control.Monad.State
|
|
import Control.Lens
|
|
import Data.List
|
|
import qualified Data.Set as S
|
|
--import System.Random
|
|
|
|
chooseOneInLink :: RandomGen g => Room -> State g Room
|
|
chooseOneInLink r = restrictToFstInLink <$> shuffleLinks r
|
|
|
|
restrictRMInLinksPD :: ((Point2,Float) -> Bool) -> Room -> Room
|
|
restrictRMInLinksPD f = rmLinks %~ restrictLinkType InLink f
|
|
|
|
restrictToFstInLink :: Room -> Room
|
|
restrictToFstInLink = rmLinks %~ f
|
|
where
|
|
f (rl:xs) | S.member InLink (_rlType rl) = rl : restrictLinkType InLink (const False) xs
|
|
| otherwise = rl : f xs
|
|
f [] = []
|
|
|
|
{- Shuffle the initial links of a room randomly. -}
|
|
randomiseOutLinks :: RandomGen g => Room -> State g Room
|
|
randomiseOutLinks r = do
|
|
let (outs,xs) = partition (S.member OutLink . _rlType) $ _rmLinks r
|
|
newLinks <- shuffle outs
|
|
return $ r {_rmLinks = newLinks ++ xs }
|
|
|
|
sortOutLinksOn :: Ord b => ((Point2,Float) -> b) -> Room -> Room
|
|
sortOutLinksOn f = overLnkType OutLink $ sortOn (f . lnkPosDir)
|
|
|
|
filterSortOutLinksOn :: Ord b => ((Point2,Float) -> Bool) -> ((Point2,Float) -> b) -> Room -> Room
|
|
filterSortOutLinksOn test f = overLnkType OutLink dosort
|
|
where
|
|
dosort [] = []
|
|
dosort xs = let (ys,zs) = partition (test . lnkPosDir) xs
|
|
in sortOn (f . lnkPosDir) ys ++ zs
|
|
|
|
{- Shuffle the order of all links of a room randomly.
|
|
- Note this does not change their types. -}
|
|
randomiseAllLinks :: RandomGen g => Room -> State g Room
|
|
randomiseAllLinks r = do
|
|
newLinks <- shuffle $ _rmLinks r
|
|
return $ r {_rmLinks = newLinks }
|
|
{- 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 r = do
|
|
newLinks <- shuffle $ _rmLinks r
|
|
return $ r {_rmLinks = newLinks }
|
|
|
|
--randomiseLinksBy
|
|
-- :: ( [(Point2,Float)] -> State g [(Point2,Float)] )
|
|
-- -> Room
|
|
-- -> State g Room
|
|
--randomiseLinksBy f r = do
|
|
-- newLinks <- f $ _rmOutLinks r ++ _rmInLinks r
|
|
-- return $ r {_rmOutLinks = init newLinks
|
|
-- , _rmInLinks = [last newLinks]
|
|
-- }
|
|
|
|
filterLinks :: RandomGen g => ((Point2,Float) -> Bool) -> Room -> State g Room
|
|
filterLinks cond r = do
|
|
newLinks <- shuffle $ filter (cond . lnkPosDir) $ _rmLinks r
|
|
return $ r {_rmLinks = newLinks}
|
|
{- | Swaps the first link in the list with one that satisfies a given property.
|
|
- Does not change the last link in the list -}
|
|
-- TODO replace all instances of this with something more sensible
|
|
changeLinkFrom :: RandomGen g => ((Point2,Float) -> Bool) -> Room -> State g Room
|
|
changeLinkFrom cond r = do
|
|
let (possibleLnks,otherLnks) = partition (cond . lnkPosDir) $ _rmLinks r
|
|
newLnks <- shuffle possibleLnks
|
|
return $ r {_rmLinks = newLnks ++ otherLnks}
|
|
{- | Swaps the last link in the list with one that satisfies a given
|
|
- property (it might swap with itself). Unsafe.
|
|
- Be careful about calling this after changeLinkFrom. -}
|
|
-- TODO replace with something more sensible
|
|
changeLinkTo :: RandomGen g => ((Point2,Float) -> Bool) -> Room -> State g Room
|
|
changeLinkTo cond r = do
|
|
let alllinks = _rmLinks r
|
|
l <- takeOne $ filter (cond . lnkPosDir) alllinks
|
|
let l' = l & rlType .~ S.singleton InLink
|
|
let newLinks = delete l alllinks
|
|
return $ r & rmLinks .~ (l':newLinks)
|
|
{- | Move a room so that the first link in '_rmInLinks' lines up to
|
|
an external point and direction.
|
|
This is intended to work when the external point is an outgoing link from another room.
|
|
-}
|
|
--shiftRoomToLink :: (Point2,Float) -> Room -> Room
|
|
--shiftRoomToLink l r
|
|
-- = shiftRoomBy l
|
|
-- . shiftRoomBy (V2 0 0 , pi-a)
|
|
-- $ shiftRoomBy (V2 0 0 -.- p , 0)
|
|
-- r
|
|
-- where
|
|
-- (p,a) = lnkPosDir $ head $ _rmInLinks r
|
|
|
|
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 %~ fmap (map (shiftPointBy shift))
|
|
& rmLinks %~ fmap (shiftLinkBy shift)
|
|
& rmPath %~ map (shiftPathBy shift)
|
|
& rmBound %~ fmap (map (shiftPointBy shift))
|
|
& rmShift %~ shiftPosDirBy shift
|
|
& rmFloor . tiles %~ map
|
|
( (tilePoly %~ map (shiftPointBy shift))
|
|
. (tileZero %~ shiftPointBy shift )
|
|
. (tileX %~ shiftPointBy shift )
|
|
)
|
|
& rmViewpoints %~ map (shiftPointBy shift)
|
|
|
|
moveRoomBy :: (Point2,Float) -> Room -> Room
|
|
moveRoomBy shift r = r
|
|
& rmPolys %~ fmap (map (shiftPointBy shift))
|
|
& rmLinks %~ fmap (shiftLinkBy shift)
|
|
& rmPath %~ map (shiftPathBy shift)
|
|
& rmBound %~ fmap (map (shiftPointBy shift))
|
|
& rmPmnts %~ map (shiftPlacement shift)
|
|
& rmFloor . tiles %~ map
|
|
( (tilePoly %~ map (shiftPointBy shift))
|
|
. (tileZero %~ shiftPointBy shift )
|
|
. (tileX %~ shiftPointBy shift )
|
|
)
|
|
& rmViewpoints %~ map (shiftPointBy shift)
|
|
|
|
shiftRoomShiftToLink :: (Point2,Float) -> (Point2,Float) -> Room -> Room
|
|
shiftRoomShiftToLink l inlink r
|
|
= shiftRoomShiftBy l
|
|
. shiftRoomShiftBy (V2 0 0 , pi-a)
|
|
$ shiftRoomShiftBy (V2 0 0 -.- 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 r = r
|
|
& 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) = (shiftPointBy s p1, shiftPointBy s p2)
|