module Dodge.Layout where
-- imports {{{
import Dodge.Data
import Dodge.Weapons
import Dodge.Critters
import Dodge.LevelGen
import Dodge.Base
import Dodge.RandomHelp
import Dodge.Prototypes
import Dodge.Path

import Geometry
--
--import Graphics.Gloss
--import Graphics.Gloss.Data.Vector
--import Graphics.Gloss.Geometry.Line
--import Graphics.Gloss.Geometry.Angle
--
import Control.Monad.State
--import Control.Monad.Loops
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
-- }}}

generateFromTree :: State StdGen (Tree Room) -> World -> World
generateFromTree t w = zoning $ placeSpots plmnts 
            $ w {_walls = wallsFromTree tr, _randGen = g
--                           ,_loadedSounds = lSounds
                           ,_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
--          lSounds = _loadedSounds 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 = 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
         
collapseTree :: Tree (Tree (Either Room Room)) -> Tree (Either Room Room)
collapseTree = g . expandTreeBy f
    where f (Node (Right x) xs) = Node (Right (Right x)) $ map f xs
          f (Node (Left x) xs) = Node (Left (Left x)) $ map f xs
          g (Node (Right x) []) = Node (Right x) []
          g (Node (Right x) xs) = Node (Left x) $ map g xs
          g (Node y ys) = Node y $ map g ys


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

allPairs :: Eq a => [a] -> [(a,a)]
allPairs xs = [(x,y) | x <- xs, y <- xs, x /= y]

treePost :: [a] -> a -> Tree a
treePost []     y = Node y []
treePost (x:xs) y = Node x [treePost xs y]

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)

doPolysIntersect :: [Point2] -> [Point2] -> Bool
doPolysIntersect (p:ps) (q:qs)
    = any isJust $ (\(a,b) (c,d) -> intersectSegSeg' a b c d) <$> pair1s <*> pair2s
    where pair1s = zip (p:ps) (ps++[p])
          pair2s = zip (q:qs) (qs++[q])
doPolysIntersect [] _  = False
doPolysIntersect _  [] = False

boundClip :: Tree Room -> Bool
boundClip t = or $ map (uncurry doPolysIntersect) [(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