54 lines
2.1 KiB
Haskell
54 lines
2.1 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 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 :<| tseq)
|
|
-- | roomIsClipping = [] -- this is called too often--might get memoized?
|
|
-- | otherwise = case ts of
|
|
-- [] -> (r :) <$> shiftRoomTreeSearchAll newBounds tseq
|
|
-- (s:ss) -> concatMap (\l -> shiftRoomTreeSearchAll bs (Node (useLink l) ss <| (tseq |> f l s))) ls
|
|
= case ts of
|
|
[] | roomIsClipping -> []
|
|
[] -> (r :) <$> shiftRoomTreeSearchAll newBounds tseq
|
|
(s:ss) -> concatMap (\l -> shiftRoomTreeSearchAll bs (Node (useLink l) ss <| (tseq |> f l s))) ls
|
|
where
|
|
convexBounds = map pointsToPoly $ _rmBound r
|
|
ls = init $ _rmLinks r
|
|
newBounds = convexBounds ++ bs
|
|
roomIsClipping = or (convexPolysOverlap <$> convexBounds <*> bs)
|
|
useLink l = r & rmLinks %~ delete l
|
|
& rmUsedLinks %~ (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 = fmap (map setLastLinkToUsed) . listToMaybe . shiftRoomTreeSearchAll [] . singleton
|
|
where
|
|
setLastLinkToUsed rm = case _rmLinks rm of
|
|
(_:_) -> rm
|
|
& rmLinks %~ init
|
|
& rmUsedLinks %~ (last (_rmLinks rm) :)
|
|
_ -> rm
|