44 lines
1.6 KiB
Haskell
44 lines
1.6 KiB
Haskell
{- |
|
|
Given a tree of rooms, tries to shift them into place in such a way that their
|
|
links connect and that none of them clip.
|
|
Returns a list; after this step the structure is determined by the actual positions of rooms.
|
|
-}
|
|
module Dodge.Layout.Tree.Shift
|
|
( shiftRoomTreeSearchAll
|
|
, shiftExpandTree
|
|
) where
|
|
import Dodge.Room.Data
|
|
import Dodge.Room.Link
|
|
import Dodge.Layout.Tree.Polymorphic
|
|
import Geometry.ConvexPoly
|
|
--import Geometry.Data
|
|
|
|
import Data.Tree
|
|
import Data.Sequence hiding (zipWith)
|
|
import Data.List (delete)
|
|
import Data.Maybe (listToMaybe)
|
|
import Control.Lens hiding (Empty, (<|) , (|>))
|
|
{- | All: Depth first search of trees of rooms, produces a list of lists of rooms that are not clipping. -}
|
|
shiftRoomTreeSearchAll
|
|
:: [ConvexPoly] -- ^ Clipping bounds
|
|
-> Seq (Tree Room) -- ^ Rooms to be added
|
|
-> [[Room]]
|
|
shiftRoomTreeSearchAll _ Empty = [[]]
|
|
shiftRoomTreeSearchAll bs (Node r ts :<| ts')
|
|
| roomIsClipping = [] -- this is called too often, but whatever
|
|
| otherwise = case ts of
|
|
[] -> (r :) <$> shiftRoomTreeSearchAll newBounds ts'
|
|
(s:ss) -> concatMap (\l -> shiftRoomTreeSearchAll bs (Node (rm l) ss <| (ts' |> f l s))) ls
|
|
where
|
|
convexBounds = map pointsToPoly $ _rmBound r
|
|
ls = init $ _rmLinks r
|
|
newBounds = convexBounds ++ bs
|
|
roomIsClipping = or (convexPolysOverlap <$> convexBounds <*> bs)
|
|
rm l = r & rmLinks %~ delete l
|
|
f l = applyToRoot (shiftRoomToLink l)
|
|
{- |
|
|
Depth first search of trees of rooms, maybe produces a list rooms that are not clipping.
|
|
-}
|
|
shiftExpandTree :: Tree Room -> Maybe [Room]
|
|
shiftExpandTree = listToMaybe . shiftRoomTreeSearchAll [] . singleton
|