--{-# 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.Room.Foreground
import Dodge.Wall.Zone
import Dodge.GameRoom
import Dodge.Bounds
import Dodge.Default.Wall
import Dodge.Room.Link
import Dodge.Randify
import Geometry
--import Geometry.ConvexPoly
import qualified IntMapHelp as IM
import Tile
import Dodge.RandomHelp
import Color
import Shape
--import Padding

import Data.List (nubBy)
import Data.Traversable
import Control.Lens
import System.Random
import Data.Foldable
import qualified Control.Foldl as L
import Data.Maybe
import Data.Function
import Control.Monad.State

generateLevelFromRoomList :: IM.IntMap Room -> World -> GenWorld
generateLevelFromRoomList gr' w = over gWorld initWallZoning 
    . over gWorld randomCompass
    . over gWorld setupWorldBounds
    . placeWires
    . doAfterPlacements
    . doInPlacements
    . doOutPlacements
    . doIndividualPlacements
    . setFloors
    . worldToGenWorld rs'
    $ w { _walls        = wallsFromRooms rs
        , _gameRooms    = gameRoomsFromRooms (IM.elems rs')
        , _pathGraph    = path
        , _pathGraphP   = pairPath
        }
  where
    path = pairsToGraph dist pairPath
    pairPath = concatMap _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 :: GenWorld -> GenWorld
putFloorTiles gw = gw & gWorld . floorTiles .~ floorsFromGenWorld gw

setFloors :: GenWorld -> GenWorld
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 :: GenWorld -> GenWorld
setTiles gw = foldr setTile gw . reverse . IM.elems $ _gRooms gw

setTile :: Room -> GenWorld -> GenWorld
setTile r gw = case _rmFloor r of
    Tiled {} -> gw
    InheritFloor -> gw & gRooms . 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 $ _gRooms 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

placeWires :: GenWorld -> GenWorld
placeWires w = w
    & gWorld .~ foldr placeRoomWires (_gWorld w) (_gRooms w)

placeRoomWires :: Room -> World -> World
placeRoomWires rm w = IM.foldr ($) w 
    $ IM.intersectionWith (placeWire rm) (_rmStartWires rm) (_rmEndWires rm)

placeWire :: Room -> RoomWire -> RoomWire -> World -> World
placeWire rm (WallWire p _ h1) (WallWire q _ h2) = foregroundShape 
    %~ (col ( thinHighBarChain h2 (map (shiftPointBy rs) doOrdering) 
            <> barPP 1.5 (addZ h1 p) (addZ h2 p)
            ) 
        <>
        )
  where
    --TODO use rmWalls for non convex rooms
    --rmWalls = foldr cutWalls [] (_rmPolys rm)
    doOrdering = orderPolygonAround rmcen (p:q:ps)
    col | clockwise = colorSH red
        | otherwise = colorSH red
    rmps = concat $ _rmPolys rm
    rmcen = centroid rmps
    clockwise = isLHS rmcen p q
    ps  | clockwise = filter leftprightq rmps
        | otherwise = filter rightpleftq rmps
    leftprightq x = isLHS rmcen p x && isRHS rmcen q x
    rightpleftq x = isRHS rmcen p x && isLHS rmcen q x
    rs = _rmShift rm

doAfterPlacements :: GenWorld -> GenWorld
doAfterPlacements gw = foldr doAfterPlacement gw (_gPlacements gw)

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

doInPlacements :: ( IM.IntMap [Placement],GenWorld) -> GenWorld
doInPlacements (im,w) = 
    let (gw,rms) = mapAccumR (doRoomInPlacements im) w (_gRooms w)
    in gw {_gRooms = rms}

doRoomInPlacements :: IM.IntMap [Placement] -> GenWorld -> Room -> (GenWorld, 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 :: GenWorld -> ( IM.IntMap [Placement], GenWorld)
doOutPlacements w = let ((pmnts,gw),rms) = mapAccumR doRoomOutPlacements (IM.empty,w) (_gRooms w)
    in (pmnts,gw{_gRooms = rms})

doRoomOutPlacements :: (IM.IntMap [Placement], GenWorld) 
    -> Room 
    -> ( (IM.IntMap [Placement], GenWorld) , 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 :: GenWorld -> GenWorld
doIndividualPlacements gw = let (gw', rms) = mapAccumR doRoomPlacements gw (_gRooms gw)
    in gw' {_gRooms = rms}

doRoomPlacements :: GenWorld -> Room -> (GenWorld, 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 & wallsZone . 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 :: GenWorld -> [(Point3,Point3)]
floorsFromGenWorld = floorsFromRooms . IM.elems . _gRooms 

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