module Dodge.Layout 
    ( module Dodge.Layout
    , module Dodge.Layout.Tree
    )
    where
-- imports {{{
import Dodge.Data
import Dodge.LevelGen
import Dodge.Base
import Dodge.RandomHelp
import Dodge.Path
import Dodge.Layout.Tree

import Geometry

import Control.Monad.State

import Control.Lens
import System.Random

import Data.List
import Data.Maybe
import Data.Tree
import Data.Either
import Data.Function
import qualified Data.Map as M

import Data.Graph.Inductive.Graph
import Data.Graph.Inductive.Basic
import Data.Graph.Inductive.PatriciaTree
import Data.Graph.Inductive.NodeMap

import qualified Data.IntMap.Strict as IM
-- }}}
-- connects a collection (tree) of rooms together
generateFromTree :: State StdGen (Tree Room) -> World -> World
generateFromTree t w = zoning $ placeSpots plmnts 
            $ w {_walls = wallsFromTree tr, _randGen = g
                           ,_pathGraph = path
                           ,_pathGraph' = pairGraph
                           ,_pathPoints = foldr insertPoint IM.empty (labNodes path) 
                           ,_pathInc = pinc}
    where tr = evalState t $ _randGen w
          plmnts = concatMap _rmPS $ flatten tr
          g = _randGen w
          path = pairsToGraph dist pairGraph
          pairGraph = makePath tr
          insertPoint  pp@(_,(x,y)) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp]
          pinc = M.fromList $ pairsToIncidence pairGraph
          zoning w = set wallsZone (IM.foldr wallInZone IM.empty (_walls w))
                        w
          wallInZone wl | dist (_wlLine wl !! 0) (_wlLine wl !! 1) <= 2*zoneSize 
                            = insertIMInZone x y wlid wl
                        | otherwise = flip (foldr (\(a,b) -> insertIMInZone a b wlid wl)) ips
            where (x,y) = zoneOfPoint $ (pHalf (_wlLine wl !! 0) (_wlLine wl !! 1))
                  wlid  = _wlID wl
                  ips = map zoneOfPoint $ divideLine (2*zoneSize) (_wlLine wl !! 0) (_wlLine wl !! 1)

makePath :: Tree Room -> [(Point2,Point2)]
makePath = concat . map _rmPath . flatten

wallsFromTree :: Tree Room -> IM.IntMap Wall
wallsFromTree t = createInnerWalls $ nubWalls $ divideWalls $ foldr cutWalls IM.empty (concatMap _rmPolys $ flatten t)

divideWall :: Wall -> [Wall]
divideWall wl
    = let (a:b:_) = _wlLine wl
          --ps = divideLine (zoneSize * 2) a b
          ps = divideLine (zoneSize * 2) a b
      in  map (\(x,y) -> wl {_wlLine = [x,y]}) $ zip (init ps) (tail ps)

divideWallIn :: Wall -> IM.IntMap Wall -> IM.IntMap Wall
divideWallIn wl wls = 
    let (wl':newWls) = divideWall wl
        k = newKey wls
        newWls' = zipWith (\i w -> w {_wlID = i}) [k..] newWls
    in  foldr (\w -> IM.insert (_wlID w) w) wls (wl':newWls')

divideWalls :: IM.IntMap Wall -> IM.IntMap Wall
divideWalls wls = IM.foldr divideWallIn wls wls

insertInZone :: Int -> Int -> a -> IM.IntMap (IM.IntMap a) -> IM.IntMap (IM.IntMap a)
insertInZone x y obj = IM.insertWith f x $ IM.singleton y obj
    where f _ = IM.insert y obj


randomiseLinks :: RandomGen g => Room -> State g (Tree (Either Room Room))
randomiseLinks r = do
    newLinks <- shuffle $ init $ _rmLinks r
    return $ connectRoom $ r {_rmLinks = newLinks ++ [last $ _rmLinks r]}
randLinks :: RandomGen g => Room -> State g Room
randLinks r = do
    newLinks <- shuffle $ init $ _rmLinks r
    return $ r {_rmLinks = newLinks ++ [last $ _rmLinks r]}

filterLinks :: RandomGen g => ((Point2,Float) -> Bool) -> Room -> State g Room
filterLinks cond r = do
    newLinks <- shuffle $ filter cond $ init $ _rmLinks r
    return $ r {_rmLinks = newLinks ++ [last $ _rmLinks r]}

changeLinkTo :: RandomGen g => ((Point2,Float) -> Bool) -> Room -> State g Room
changeLinkTo cond r = do
    l <- takeOne $ filter cond $ _rmLinks r
    let newLinks = delete l (_rmLinks r) ++ [l]
    return $ r {_rmLinks = newLinks}


-- Left elements get new children, Right elements inherit the children from the
-- mapped over node
composeTreeWith :: (a -> Tree (Either b b)) -> Tree a -> Tree (Either b b)
composeTreeWith f (Node x []) = f x
composeTreeWith f (Node x xs) = paste xs $ f x
    where paste xs (Node (Right y) _) = Node (Left y) (map (composeTreeWith f) xs)
          paste xs (Node (Left y) ys) = Node (Left y) (map (paste xs) ys)

-- the old version of this used a version of polysIntersect with intersectSegSeg'
boundClip :: Tree Room -> Bool
boundClip t = or $ map (uncurry polysIntersect) [(x,y) | x<- xs, y<-xs, x>y]
                    ++ map f [(ps,qs) | ps <- xs, qs <-xs, ps/=qs]
    where xs = map _rmBound $ flatten t
          f ([],qs) = False
          f ((p:_),qs) = pointInPolygon p qs

noBoundClip :: Tree Room -> Bool
noBoundClip = not . boundClip

connectRoom :: a -> Tree (Either a a)
connectRoom r = Node (Right r) [] 

deadRoom :: a -> Tree (Either a a)
deadRoom r = Node (Left r) []

onRoot :: (a -> a) -> Tree a -> Tree a
onRoot f (Node t ts) = Node (f t) ts

shiftRoomTree :: Tree Room -> Tree Room
shiftRoomTree (Node t []) = Node t []
shiftRoomTree (Node t ts) = Node t $ zipWith (\l -> shiftRoomTree . onRoot (shiftRoomBy l . f)) 
                                             (_rmLinks t) 
                                             ts
    where f r = shiftRoomBy ((0,0) -.- (rotateV (pi-a) p),0) $ shiftRoomBy ((0,0),pi-a)  r
                where (p,a) = last $ _rmLinks r

shiftRoomBy :: (Point2,Float) -> Room -> Room
shiftRoomBy shift@(pos,rot) r = 
   over rmPolys (fmap (map (shiftPointBy shift)))
   $ over rmLinks (fmap (shiftLinkBy shift))
   $ over rmPath (map (shiftPathPointBy shift))
   $ over rmPS (fmap (shiftPSBy shift))
   $ over rmBound (map (shiftPointBy shift))
   r

shiftPathPointBy s (p1,p2) = (shiftPointBy s p1, shiftPointBy s p2)

shiftLinkBy (pos,rot) (p,r) = (shiftPointBy (pos,rot) p, r + rot)
shiftPSBy (pos,rot) ps = case ps of
    PS {} -> over psPos (shiftPointBy (pos,rot))
                            $ over psRot (+rot)
                            ps