{-# LANGUAGE TupleSections #-}
module Dodge.Layout 
    where
import Dodge.Data
import Dodge.LevelGen
import Dodge.LevelGen.Data
import Dodge.LevelGen.StaticWalls
import Dodge.LevelGen.Pathing
import Dodge.Placements.Spot
import Dodge.Base
import Dodge.Zone
import Dodge.GameRoom
import Dodge.Bounds
--import Dodge.RandomHelp
--import Dodge.Graph
import Dodge.Layout.Tree.Polymorphic (applyToRoot)
import Dodge.Room.Data
import Dodge.Room.AddTile
import Dodge.Default.Wall
import Geometry
--import Geometry.Data
import Dodge.Room.Link
import qualified IntMapHelp as IM
--import Dodge.Debug.LinkDecoration
import Picture.Data
import Tile
import Polyhedra
import Polyhedra.Data

import Data.List (nubBy, partition,mapAccumR)
import Control.Monad.State
import Control.Lens
import System.Random
import Data.Tree
--import Data.Graph.Inductive.Graph (labNodes)
--import qualified Data.Map as M
import Data.Foldable
import qualified Control.Foldl as L
import Data.Maybe

generateLevelFromRoomList :: State StdGen [Room] -> World -> World
generateLevelFromRoomList gr w 
    = updateWallZoning 
    . setupWorldBounds
    . flip (foldr $ flip placeSpot) plmnts
    $ w { _walls        = wallsFromRooms rs
        , _floorTiles   = floorsFromRooms rs
        , _gameRooms    = gameRoomsFromRooms rs
        , _pathGraph    = path
        , _pathGraphP   = pairPath
        }
  where
    path = pairsToGraph dist pairPath
    pairPath = concatMap _rmPath rs
    plmnts = concatMap (\r -> map (_rmShift r ,) (assignPlacementSpots r)) rs
    rs = zipWith addTile zs . evalState gr $ _randGen w
    zs = map fromIntegral $ randomRs (0,63::Int) $ _randGen w

-- the idea is to allow use of link coordinates for placements
-- though the implementation is clunky
assignPlacementSpots :: Room -> [Placement]
assignPlacementSpots rm = plmnts ++ plmnts'
  where
    (lnkplmnts, plmnts) = partition islnk (_rmPS rm)
    islnk Placement{_placementSpot=PSLnk{}} = True
    islnk _ = False
    (_,plmnts') = mapAccumR f (_rmLinks rm) lnkplmnts
    (la,lb) = head $ _rmUsedLinks rm
    lnkTo = (la,lb+1.5*pi)
    f lnks plmnt = 
        let (x:xs,ys) = partition (_psLinkTest $ _placementSpot plmnt) lnks
            thepair = bimap (invShiftPointBy lnkTo) (\r -> r - snd lnkTo)
                $ _psLinkShift (_placementSpot plmnt) x
        in (xs++ys, updatePS (updatePSLnkUsing thepair) plmnt)

updatePSLnkUsing :: (Point2,Float) -> PlacementSpot -> PlacementSpot
updatePSLnkUsing pf PSLnk{_psLinkShift=f} = uncurry PS $ f pf
updatePSLnkUsing _ ps = ps

setupWorldBounds :: World -> World
setupWorldBounds w = w
    & worldBounds . bdMinX .~ f minx
    & worldBounds . bdMaxX .~ f maxx
    & worldBounds . bdMinY .~ f miny
    & worldBounds . 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

updateWallZoning :: World -> World
updateWallZoning w = set (wallsZone . znObjects) (foldl' (flip wallInZone) IM.empty (_walls w)) w
  where
    wallInZone wl 
        | uncurry dist (_wlLine wl) <= 2*zoneSize = insertIMInZone x y wlid wl
        | otherwise = flip (foldl' (flip $ \(a,b) -> insertIMInZone a b wlid wl)) ips
      where 
        (x,y) = zoneOfPoint $ uncurry pHalf (_wlLine wl)
        wlid  = _wlID wl
        ips = map zoneOfPoint $ uncurry (divideLine zoneSize) (_wlLine wl)


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

-- consider nubbing walls after dividing them
wallsFromTree :: Tree Room -> IM.IntMap Wall
wallsFromTree t = 
--    createInnerWalls 
    divideWalls 
    . assignKeys 
    . removeInverseWalls
    . foldl' (flip cutWalls) [] -- map (map (g . roundPoint2)) 
--    . map (map roundPoint2)
    $ concatMap _rmPolys (flatten t)
  where
    assignKeys = IM.fromList . zip [0..] . zipWith f [0..]
    f i (x,y) = defaultWall {_wlLine = (x,y) , _wlID = i}

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

gameRoomsFromRooms :: [Room] -> [GameRoom]
gameRoomsFromRooms = map f
  where
    f rm = GameRoom
        { _grViewpoints = _rmViewpoints rm ++ (map fst . foldl' (flip cutWalls) [] $ _rmPolys rm)
            ++ map fst (_rmLinks rm)
        , _grViewpointsEx = map fst (_rmUsedLinks rm)
        , _grBound = expandPolyByFixed 100 . convexHullSafe . nubBy closePoints 
            . concat $ _rmBound rm ++ _rmPolys rm
        , _grDir   = snd . head $ _rmUsedLinks rm
        , _grName  = _rmName rm
        }
    closePoints x y = roundPoint2 x == roundPoint2 y

floorsFromRooms :: [Room] -> [(Point3,Point3)]
floorsFromRooms = concatMap (concatMap tToRender . _rmFloor)

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