--{-# LANGUAGE TupleSections #-}
module Dodge.Layout 
    ( generateLevelFromRoomList
    ) where
import Data.Tile
import Dodge.Data
import Dodge.Path
import Dodge.ShiftPoint
import Dodge.Placement.PlaceSpot
--import Dodge.LevelGen.Data
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 Geometry.ConvexPoly
import qualified IntMapHelp as IM
import Tile
import RandomHelp

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
        }
  where
    path = pairsToGraph pairPath
    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