{- | 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 Dodge.RoomLink
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) = printHeader 
    >> posRms (map pointsToPoly $ _rmBound r) (r,i) (zipCount ts) Empty

posRms :: [ConvexPoly]
    -> RoomInt
    -> [(Int,Tree RoomInt)]     -- the list of children, with indices
    -> Seq (Tree RoomInt)
    -> IO (Maybe [Room])
posRms bounds (parent,_) [] st = case st of
    Empty                   -> return $ Just [parent]
    Node childi ts :<| tseq -> fmap (parent:) <$> posRms bounds childi (zipCount ts) tseq
posRms bounds parenti@(parent,_) ( (numChild,t@(Node childi _) ):its) tseq = do
    printInfoCheckNum parenti numChild childi
    tryParentLinks $ zipCount $ rmOutLinks parent
  where
    tryParentLinks [] = putStrLn "no viable link pairs, backtrack" >> return Nothing
    tryParentLinks ((j,outlnk):ls) = tryChildLinks $ zipCount (rmInLinks $ fst childi)
      where
        tryChildLinks [] = tryParentLinks ls
        tryChildLinks ((numinlink,il):ils) 
            | clipping = tryChildLinks ils
            | otherwise = do
                putStrLn $ show j ++ "-"++show numinlink
                mayrs <- posRms (convexBounds ++ bounds) 
                    (first updateparent parenti) its (tseq |> shiftedt)
                case mayrs of
                    Just rms -> return $ Just rms
                    Nothing -> printInfo parenti numChild childi
                        >> tryChildLinks ils
          where
            convexBounds = map pointsToPoly $ _rmBound r'
            clipping = or (convexPolysOverlap <$> convexBounds <*> bounds)
            updateparent rm = doLnkEff (lnkPosDir outlnk) $ rm 
                & rmLinks %~ delete outlnk & rmPos %~ (uncurry (UsedOutLink numChild) (lnkPosDir outlnk) :)
            l' = shiftLinkBy (_rmShift parent) outlnk
            r' = doRoomShift . fst $ rootLabel shiftedt
            updatechild rm = rm & rmLinks %~ delete il 
                & rmPos %~ ( (uncurry (UsedInLink 0) (lnkPosDir il):)
                    . (map (uncurry UnusedLink . lnkPosDir) (delete il (_rmLinks rm)) ++) )
            shiftedt = applyToRoot (first $ updatechild . shiftRoomShiftToLink' (lnkPosDir l') (lnkPosDir il)) t

zipCount :: [a] -> [(Int,a)]
zipCount = Prelude.zip [0..]

printColumns :: [Int] -> [String] -> IO ()
printColumns (i:is) (s:strs) = putStr (rightPad i ' ' s) >> printColumns is strs
printColumns _ strs = putStrLn $ concat strs

theColumns :: [String] -> IO ()
theColumns = printColumns [20,5,20,20]

printHeader :: IO ()
printHeader = theColumns ["Parent","Cnum","Child","Link pair"]

printInfo :: RoomInt -> Int -> RoomInt -> IO ()
printInfo (parentrm,parenti) childn (childrm,childi) = do
    putStr $ rpns 20 (_rmName parentrm ++ "-" ++ show parenti )
          ++ rpns 5 (show childn ++ " ")
          ++ rpns 20 (_rmName childrm ++ "-" ++ show childi )
  where
    rpns x s = rightPadNoSquash x ' ' s
printInfoCheckNum :: RoomInt -> Int -> RoomInt -> IO ()
printInfoCheckNum p 0 c = printInfo p 0 c
printInfoCheckNum _ childn (childrm,childi) = do
    putStr $ rpns 20 ("")
          ++ rpns 5 (show childn ++ " ")
          ++ rpns 20 (_rmName childrm ++ "-" ++ show childi )
  where
    rpns x s = rightPadNoSquash x ' ' s

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