{- | 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 LensHelp hiding (Empty, (<|) , (|>))
--import Control.Lens hiding (Empty, (<|) , (|>))

import qualified Data.Set as S
import Data.Tree
import Data.Sequence hiding (zipWith)
import Data.List (delete)
import Data.Bifunctor

type RoomInt = (Room,Int)

positionRoomsFromTree :: Tree RoomInt -> IO (Maybe [RoomInt])
positionRoomsFromTree (Node (r,i) ts) = printColumnTitles 
    >> fmap (fmap (map $ first createUnusedLinkPos))
        (posRms (map pointsToPoly $ _rmBound r') (r',i) (zipCount ts) Empty)
  where
    r' = r & rmMID ?~ 0

posRms :: [ConvexPoly]
    -> RoomInt
    -> [(Int,Tree RoomInt)]     -- the list of children, with indices
    -> Seq (Tree RoomInt)
    -> IO (Maybe [RoomInt])
posRms bounds (parent,i) [] st = case st of
    Empty                   -> return $ Just [(parent,i)]
    Node childi ts :<| tseq -> fmap ((parent,i):) <$> posRms bounds childi (zipCount ts) tseq
posRms bounds parenti@(parent,_) ( (numChild,t@(Node childi _) ):its) tseq = do
    printInfoCheckNum parenti numChild childi
    tryParentLinks outlinks
  where
    child = fst childi
    outlinks = zipCount
        . Prelude.filter (not . S.null . S.intersection (_rmConnectsTo child) . _rlType) 
        $ _rmLinks parent
    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 
                    (newBounds ++ bounds)
                    (first updateparent parenti) 
                    its 
                    (tseq |> shiftedt)
                case mayrs of
                    Just rms -> return $ Just rms
                    Nothing -> printInfo parenti numChild childi
                        >> tryChildLinks ils
          where
            newBounds = map pointsToPoly . _rmBound . doRoomShift . fst $ rootLabel shiftedt
            clipping = or (convexPolysOverlap <$> newBounds <*> bounds)
            updateparent rm = doLnkEff (lnkPosDir outlnk) $ rm 
                & rmLinks    %~ delete outlnk 
                & rmPos      .:~ UsedOutLink
                    { _rpChildNum = numChild 
                    , _rpOutRoomID = snd childi
                    , _rpPos = fst (lnkPosDir outlnk)
                    , _rpDir = snd (lnkPosDir outlnk)
                    , _rpLinkType = _rlType outlnk
                    }
                & rmChildren .:~ snd childi
            shiftedoutlink = shiftLinkBy (_rmShift parent) outlnk
            updatechild rm = rm 
                & rmMParent ?~ snd parenti
                & rmMID     ?~ snd childi
                & rmLinks   %~ delete il 
                & rmPos     .:~ UsedInLink 
                    { _rpInRoomID = 0
                    , _rpPos = fst (lnkPosDir il)
                    , _rpDir = snd (lnkPosDir il)
                    , _rpLinkType = _rlType il
                    }
            shiftedt = applyToRoot
                (first $ updatechild . shiftRoomShiftToLink (lnkPosDir shiftedoutlink) (lnkPosDir il)) 
                t

createUnusedLinkPos :: Room -> Room
createUnusedLinkPos rm = rm & rmPos .++~ map f (_rmLinks rm)
  where
    f rl = UnusedLink
        { _rpPos = _rlPos rl
        , _rpDir = _rlDir rl
        , _rpLinkType = _rlType rl
        }

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

printColumns :: [Int] -> [String] -> IO ()
printColumns is ss = printPartialColumns is ss >> putStrLn ""

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

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

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

printInfo :: (Show a) => RoomInt -> a -> RoomInt -> IO ()
printInfo (parentrm,parenti) childn (childrm,childi) = printPartialColumns
    [20,5,20]
    [_rmName parentrm ++ "-" ++ show parenti 
    ,show childn ++ " "
    ,_rmName childrm ++ "-" ++ show childi 
    ]

printInfoCheckNum :: (Show a, Eq a, Num a) => RoomInt -> a -> RoomInt -> IO ()
printInfoCheckNum (parentrm,parenti) childn (childrm,childi) = printPartialColumns
    [20,5,20]
    [rname
    ,show childn
    ,_rmName childrm ++ "-" ++ show childi
    ]
  where
    rname = case childn of
        0 -> _rmName parentrm ++ "-" ++ show parenti
        _ -> ""

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