72 lines
2.3 KiB
Haskell
72 lines
2.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
|
|
where
|
|
import Dodge.LevelGen
|
|
import Dodge.LevelGen.Data
|
|
import Dodge.Room.Data
|
|
import Dodge.RandomHelp
|
|
import Geometry
|
|
|
|
import System.Random
|
|
import Control.Monad.State
|
|
import Control.Lens
|
|
import Data.List (delete)
|
|
|
|
{- Shuffle the initial links of a room randomly. -}
|
|
randomiseOutLinks :: RandomGen g => Room -> State g Room
|
|
randomiseOutLinks r = do
|
|
newLinks <- shuffle $ init $ _rmLinks r
|
|
return $ r {_rmLinks = newLinks ++ [last $ _rmLinks r]}
|
|
|
|
{- Shuffle all links of a room randomly. -}
|
|
randomiseAllLinks :: RandomGen g => Room -> State g Room
|
|
randomiseAllLinks r = do
|
|
newLinks <- shuffle $ _rmLinks r
|
|
return $ r {_rmLinks = newLinks}
|
|
|
|
filterLinks :: RandomGen g => ((Point2,Float) -> Bool) -> Room -> State g Room
|
|
filterLinks cond r = do
|
|
newLinks <- shuffle $ filter cond $ init $ _rmLinks r
|
|
return $ r {_rmLinks = newLinks ++ [last $ _rmLinks r]}
|
|
|
|
changeLinkTo :: RandomGen g => ((Point2,Float) -> Bool) -> Room -> State g Room
|
|
changeLinkTo cond r = do
|
|
l <- takeOne $ filter cond $ _rmLinks r
|
|
let newLinks = delete l (_rmLinks r) ++ [l]
|
|
return $ r {_rmLinks = newLinks}
|
|
|
|
{- | Move a room so that the last link in '_rmLinks' 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 ((0,0) -.- (rotateV (pi-a) p),0)
|
|
$ shiftRoomBy ((0,0),pi-a) r
|
|
where
|
|
(p,a) = last $ _rmLinks r
|
|
|
|
shiftRoomBy :: (Point2,Float) -> Room -> Room
|
|
shiftRoomBy shift@(pos,rot) r =
|
|
over rmPolys (fmap (map (shiftPointBy shift)))
|
|
$ over rmLinks (fmap (shiftLinkBy shift))
|
|
$ over rmPath (map (shiftPathPointBy shift))
|
|
$ over rmPS (fmap (shiftPSBy shift))
|
|
$ over rmBound (map (shiftPointBy shift))
|
|
r
|
|
|
|
shiftLinkBy (pos,rot) (p,r) = (shiftPointBy (pos,rot) p, r + rot)
|
|
shiftPSBy (pos,rot) ps = case ps of
|
|
PS {} -> over psPos (shiftPointBy (pos,rot))
|
|
$ over psRot (+rot)
|
|
ps
|
|
|
|
shiftPathPointBy s (p1,p2) = (shiftPointBy s p1, shiftPointBy s p2)
|