{- | 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.
Creates a list of rooms; after this step the structure is determined by the actual positions of rooms.  -}
module Dodge.Tree.Shift
    ( positionRoomsFromTree
    ) where
import Dodge.LevelGen.Data
import Dodge.Room.Link
import Dodge.Tree.Polymorphic
import Geometry.ConvexPoly
import Geometry.Data
import Padding

import Data.Tree
import Data.Sequence hiding (zipWith)
import Data.List (delete)
import Data.Bifunctor
import Control.Lens hiding (Empty, (<|) , (|>))

type RoomInt = (Room,Int)

positionRoomsFromTree :: Tree RoomInt -> IO (Maybe [Room])
positionRoomsFromTree (Node (r,i) ts) = posRms (map pointsToPoly $ _rmBound r) (r,i) 0 ts Empty

posRms :: [ConvexPoly]
    -> RoomInt
    -> Int -- ^ the number of children already placed
    -> [Tree RoomInt]
    -> Seq (Tree RoomInt)
    -> IO (Maybe [Room])
posRms bounds (parent,_) _ [] st = case st of
    Empty -> return $ Just []
    Node childi ts :<| tseq 
        -> fmap (finalLinksUpdate parent:) <$> posRms bounds childi 0 ts tseq
posRms bounds parenti@(pr,i) numChild (t@(Node (cr,i') _):ts) tseq = do
    putStr $ (rpns 20 (_rmName cr ++ "-" ++ show i')) 
          ++ (rpns 9 (" child " ++ show numChild ))
          ++ (rpns 25 (" of " ++ _rmName pr ++ "-" ++ show i ))
    tryLinks (0::Int) (_rmLinks parent)
  where
    rpns x s = rightPadNoSquash x ' ' s
    parent = fst parenti
    tryLinks _ [] = putStrLn "all links tried" >> return Nothing
    tryLinks j (l:ls) 
        | clipping  = tryLinks (j+1) ls
        | otherwise = do
            putStrLn $ "placed at link " ++ show j
            mayrs <- posRms (convexBounds ++ bounds) 
                (first upr parenti) (numChild + 1) ts (tseq |> shiftedt)
            case mayrs of
                Nothing -> putStr ("Backtracking to room " ++ show i' ++ ": ") >> tryLinks (j+1) ls
                Just rs -> return (Just rs)
      where
        convexBounds = map pointsToPoly $ _rmBound r'
        clipping = or (convexPolysOverlap <$> convexBounds <*> bounds)
        upr rm = doLnkEff l $ rm & rmLinks %~ delete l & rmPos %~ (uncurry (OutLink numChild) l :)
        l' = shiftLinkBy (_rmShift parent) l
        r' = doRoomShift . fst $ rootLabel shiftedt
        shiftedt = applyToRoot (first $ shiftRoomShiftToLink l') t

doLnkEff :: (Point2,Float) -> Room -> Room
doLnkEff x rm = case _rmLinkEff rm of
    (eff:effs) -> eff x $ rm & rmLinkEff .~ effs
    _ -> rm