--{-# LANGUAGE TupleSections #-}
module Dodge.Layout 
    ( generateLevelFromRoomList
    ) where
import Data.Tile
import Dodge.Data.GenWorld
import Dodge.Path
import Dodge.Zone.Update
import Dodge.ShiftPoint
import Dodge.Placement.PlaceSpot
import Dodge.LevelGen.StaticWalls
import Dodge.LevelGen.LevelStructure
import Dodge.Wall.Zone
import Dodge.GameRoom
import Dodge.Default.Wall
import Dodge.Room.Link
import Dodge.Randify
import Geometry
import qualified IntMapHelp as IM
import Tile
import RandomHelp

import Data.Graph.Inductive (labNodes,labEdges)
import Data.List (nubBy)
import Data.Traversable
import Control.Lens
import Data.Foldable
import qualified Control.Foldl as L
import Data.Maybe
import Data.Function

generateLevelFromRoomList :: IM.IntMap Room -> World -> World
generateLevelFromRoomList gr' w = initWallZoning 
    . randomCompass
    . setupWorldBounds
    . doAfterPlacements
    . doInPlacements
    . doOutPlacements
    . doIndividualPlacements
    . setFloors
    . worldToGenWorld rs'
    $ w { _walls        = wallsFromRooms rs
        , _gameRooms    = gameRoomsFromRooms (IM.elems rs')
        , _pathGraph    = path
        , _pathGraphP   = pairPath
        }
        & pnZoning   %~ (\zn -> foldl' (flip $ updateZoning (:)) (zn & znObjects .~ mempty)
<<<<<<< HEAD
            (labNodes (_pgGraph path)))
        & peZoning   %~ (\zn -> foldl' (flip $ updateZoning (:)) (zn & znObjects .~ mempty)
            (labEdges (_pgGraph path)))
  where
    path = pairsToGraph pairPath
=======
            (labNodes path))
        & peZoning   %~ (\zn -> foldl' (flip $ updateZoning (:)) (zn & znObjects .~ mempty)
            (labEdges path))
  where
    (_,path) = pairsToGraph pairPath
>>>>>>> efficientRuntime
    pairPath = foldMap _rmPath rs
    rs = map doRoomShift $ IM.elems rs'
    rs'= mapM shuffleRoomPos gr' & evalState $ _randGen w

randomCompass :: World -> World
randomCompass w = w & cameraRot .~ (takeOne [0,0.5*pi,pi,1.5*pi] & evalState $ _randGen w)

putFloorTiles :: World -> World
putFloorTiles gw = gw & floorTiles .~ floorsFromGenWorld gw

setFloors :: World -> World
setFloors = putFloorTiles . setTiles

-- note the order of traversal of the rooms is important
-- hence the reverse
-- this is not ideal: should do this in some more sensible way
setTiles :: World -> World
setTiles gw = foldr setTile gw . reverse . IM.elems $ _genRooms gw

setTile :: Room -> World -> World
setTile r gw = case _rmFloor r of
    Tiled {} -> gw
    InheritFloor -> gw & genRooms . ix (fromJust (_rmMID r)) . rmFloor .~ Tiled [t & tilePoly .~ poly]
  where
    t = case _rmMParent r of
        Nothing -> Tile poly (V2 0 0) (V2 1 0) 16
        Just pid -> head $ _tiles $ _rmFloor $ _genRooms gw IM.! pid
    poly = orderPolygon . convexHullSafe . nubBy ((==) `on` roundPoint2) $ concat $ _rmPolys r

shuffleRoomPos :: RandomGen g => Room -> State g Room
shuffleRoomPos rm = do
    newPos <- shuffle $ _rmPos rm
    return $ rm & rmPos .~ newPos

doAfterPlacements :: World -> World
doAfterPlacements gw = foldr doAfterPlacement gw (_genPlacements gw)

doAfterPlacement :: [(Placement,Int)] -> World -> World
doAfterPlacement pmntis gw = gRandify gw $ do
    (pmnt,i) <- takeOne pmntis
    let (newgw,rm) = fst $ placeSpot (gw,_genRooms gw IM.! i) pmnt
    return $ newgw & genRooms . ix i .~ rm

doInPlacements :: ( IM.IntMap [Placement],World) -> World
doInPlacements (im,w) = 
    let (gw,rms) = mapAccumR (doRoomInPlacements im) w (_genRooms w)
    in gw & genRooms .~ rms

doRoomInPlacements :: IM.IntMap [Placement] -> World -> Room -> (World, Room)
doRoomInPlacements im w rm = foldr f (w,rm) $ _rmInPmnt rm
  where
    f (InPlacement plf i) (w',r') = fst $ placeSpot (w',r') (plf $ im IM.! i)

doOutPlacements :: World -> ( IM.IntMap [Placement], World)
doOutPlacements w = let ((pmnts,gw),rms) = mapAccumR doRoomOutPlacements (IM.empty,w) (_genRooms w)
    in (pmnts,gw & genRooms .~ rms)

doRoomOutPlacements :: (IM.IntMap [Placement], World) 
    -> Room 
    -> ( (IM.IntMap [Placement], World) , Room )
doRoomOutPlacements imw r = foldr f ( imw, r ) $ _rmOutPmnt r
  where
    f (OutPlacement pl i) ( (im,w) , rm ) = 
        let ((neww,newrm),plmnts) = placeSpot (w,rm) pl
        in ((IM.insert i plmnts im, neww) , newrm )

doIndividualPlacements :: World -> World
doIndividualPlacements gw = let (gw', rms) = mapAccumR doRoomPlacements gw (_genRooms gw)
    in gw' & genRooms .~ rms

doRoomPlacements :: World -> Room -> (World, Room)
doRoomPlacements w rm = foldl' (\wr -> fst . placeSpot wr) (w,rm) $ _rmPmnts rm

setupWorldBounds :: World -> World
setupWorldBounds w = w & worldBounds %~
    ( (bdMinX .~ f minx)
    . (bdMaxX .~ f maxx)
    . (bdMinY .~ f miny)
    . (bdMaxY .~ f maxy)
    )
  where
    f = fromMaybe 0
    ps = IM.map (fst . _wlLine) $ _walls w
    (minx,maxx,miny,maxy) = L.fold ((,,,) 
        <$> L.premap fstV2 L.minimum
        <*> L.premap fstV2 L.maximum
        <*> L.premap sndV2 L.minimum
        <*> L.premap sndV2 L.maximum
        ) ps

--polyhedrasToEdges :: [Polyhedra] -> [Point3]
--polyhedrasToEdges = concatMap tflat4 . concatMap polyToEdges

initWallZoning :: World -> World
initWallZoning w = foldl' (flip insertWallInZones) (w & wlZoning . znObjects .~ IM.empty) (_walls w)

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

wallsFromRooms :: [Room] -> IM.IntMap Wall
wallsFromRooms = --    divideWalls .
    IM.fromAscList 
    . zipWith f [0..] 
    . removeInverseWalls 
    . foldl' (flip cutWalls) [] 
    . concatMap _rmPolys
  where
    f i (x,y) = (i, defaultWall {_wlLine = (x,y) , _wlID = i})

-- TODO sort out shifting before or after etc
gameRoomsFromRooms :: [Room] -> [GameRoom]
gameRoomsFromRooms = fmap gameRoomFromRoom

gameRoomFromRoom :: Room -> GameRoom
gameRoomFromRoom rm = GameRoom
    { _grViewpoints = map doshift $ _rmViewpoints rm ++ (map fst . foldl' (flip cutWalls) [] $ _rmPolys rm)
        ++ mapMaybe filterUnusedLinks (_rmPos rm)
    , _grViewpointsEx = concatMap filterUsedLinks (_rmPos rm)
    , _grBound = map doshift $ expandPolyCorners 50 . convexHullSafe . nubBy closePoints 
        . concat $ _rmBound rm ++ _rmPolys rm
    , _grDir   = getDir $ _rmPos rm
    , _grLinkDirs = mapMaybe undir $ _rmPos rm
    , _grName  = _rmName rm
    }
  where
    doshift = shiftPointBy (_rmShift rm)
    doubleShift p a = map doshift
        [p +.+ 10 *.* unitVectorAtAngle a
        ,p -.- 10 *.* unitVectorAtAngle a
        ]
    filterUnusedLinks rp = case _rpLinkStatus rp of
        UnusedLink{} -> Just $ _rpPos rp
        _ -> Nothing
    filterUsedLinks rp = case _rpLinkStatus rp of
        UsedOutLink{} -> doubleShift (_rpPos rp) (_rpDir rp)
        UsedInLink{} -> doubleShift (_rpPos rp) (_rpDir rp)
        _ -> []
    undir rp = case _rpLinkStatus rp of
        UsedOutLink{} -> ma
        UsedInLink{}  -> ma
        _ -> Nothing
      where
        ma = Just $ 0.5*pi + _rpDir rp + snd (_rmShift rm)
    closePoints x y = roundPoint2 x == roundPoint2 y
    getDir (rp:xs) = case _rpLinkStatus rp of
        UsedInLink {} -> _rpDir rp + snd (_rmShift rm)
        _ -> getDir xs
    getDir _ = 0 -- fallback

floorsFromRooms :: [Room] -> [(Point3,Point3)]
floorsFromRooms = concatMap (concatMap tileToRenderList . getTiles . _rmFloor . doRoomShift)

floorsFromGenWorld :: World -> [(Point3,Point3)]
floorsFromGenWorld = floorsFromRooms . IM.elems . _genRooms

getTiles :: Floor -> [Tile]
getTiles fl = case fl of
    Tiled xs -> xs
    _ -> error "tiles not correctly set for some room"

--divideWall :: Wall -> [Wall]
--divideWall wl
--    = let (a,b) = _wlLine wl
--          ps = divideLine (zoneSize * 2) a b
--      in  zipWith (\ x y -> wl & wlLine .~ (x,y) ) (init ps) (tail ps)

--divideWallIn :: Wall -> IM.IntMap Wall -> IM.IntMap Wall
--divideWallIn wl wls = 
--    let (wl':newWls) = divideWall wl
--        k = IM.newKey wls
--        newWls' = zipWith (\i w -> w {_wlID = i}) [k..] newWls
--    in  foldl' (flip $ \w -> IM.insert (_wlID w) w) wls (wl':newWls')
--
--divideWalls :: IM.IntMap Wall -> IM.IntMap Wall
--divideWalls wls = foldl' (flip 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

--shiftRoomTree :: Tree Room -> Tree Room
--shiftRoomTree (Node t []) = Node t []
--shiftRoomTree (Node t ts) = Node t 
--    $ zipWith (\l -> shiftRoomTree . applyToRoot (shiftRoomToLink l)) 
--    (_rmLinks t) 
--    ts

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

--addTile :: Float -> Room -> Room
--addTile z r
--    | not (null (_rmFloor r)) || null rp = r
--    | otherwise = r & rmFloor .~ [makeTileFromPoly poly z]
--  where
--    rp = _rmPolys r
--    poly = orderPolygon . convexHullSafe . nubBy ((==) `on` roundPoint2) $ concat rp