loop/src/Dodge/Layout.hs

module Dodge.Layout 
    where
import Dodge.Data
import Dodge.LevelGen
import Dodge.LevelGen.StaticWalls
--import Dodge.LevelGen.Data
import Dodge.Base
import Dodge.Base.Zone
import Dodge.GameRoom
--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 Control.Monad.State
import Control.Lens
import System.Random
--import Data.List
--import Data.Maybe
import Data.Tree
import Data.Graph.Inductive.Graph (labNodes)
import qualified Data.Map as M
import Data.Foldable

generateLevelFromRoomList :: State StdGen [Room] -> World -> World
generateLevelFromRoomList gr w = updateWallZoning 
--    . initializeStaticWalls
    . setupForegroundEdgeVerxs
    . placeSpots plmnts
--    . addRoomPolyDecorations rs
--    . addRoomLinkDecorations rs
    $ w { _walls = wallsFromRooms rs
        , _floorTiles = floorsFromRooms rs
        , _gameRooms  = gameRoomsFromRooms rs
        , _pathGraph = path
        , _pathGraph' = pairPath
        }
  where
    path = pairsToGraph dist pairPath
    pairPath = concatMap _rmPath rs
    plmnts = concatMap _rmPS rs
    rs = zipWith addTile zs rs'
    zs = map fromIntegral $ randomRs (0,63::Int) $ _randGen w
    rs' = evalState gr $ _randGen w

setupForegroundEdgeVerxs :: World -> World
setupForegroundEdgeVerxs w = w & foregroundEdgeVerx .~ polyhedrasToEdges (_foregroundDecorations w)

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

-- | connects a collection (tree) of rooms together
generateFromTree :: State StdGen (Tree Room) -> World -> World
generateFromTree t w = updateWallZoning $ placeSpots plmnts 
   $ w  {_walls         = wallsFromTree tr
        ,_pathGraph     = path
        ,_pathGraph'    = pairGraph
        ,_pathPoints    = foldl' (flip insertPoint) IM.empty (labNodes path) 
        ,_pathInc       = pinc
        }
  where 
    tr = evalState t $ _randGen w
    plmnts = concatMap _rmPS $ flatten tr
    path = pairsToGraph dist pairGraph
    pairGraph = makePath tr
    insertPoint  pp@(_,V2 x y) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp]
    pinc = M.fromList $ pairsToIncidence pairGraph

initializeStaticWalls :: World -> World
initializeStaticWalls w = w & staticWalls %~ (\wls' -> foldl' (flip wallToWall) wls' wls)
    & walls %~ IM.filter (not . wlIsWall)
  where
    wls = [wl | wl@Wall{} <- IM.elems $ _walls w]
    wlIsWall Wall{} = True
    wlIsWall _ = False

wallToWall :: Wall -> IM.IntMap (IM.IntMap [Wall']) -> IM.IntMap (IM.IntMap [Wall'])
wallToWall wl wls = foldl' (flip f) wls is
  where
    is = uncurry zoneOfLine (_wlLine wl)
    wl' = Wall' {_wlLine' = _wlLine wl, _wlColor' = _wlColor wl}
    f (x,y) = insertInZoneWith x y (++) [wl']

updateWallZoning :: World -> World
updateWallZoning w = set wallsZone (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 . zip [0..] . zipWith f [0..] . removeInverseWalls 
        . foldl' (flip cutWalls) [] . concatMap _rmPolys
  where
    f i (x,y) = defaultWall {_wlLine = (x,y) , _wlID = i}

gameRoomsFromRooms :: [Room] -> [GameRoom]
gameRoomsFromRooms = map f
  where
    f rm = GameRoom
        { _grViewpoints = (map fst . foldl' (flip cutWalls) [] $ _rmPolys rm)
            ++ map fst (_rmLinks rm)
        , _grBound = expandPolyByFixed 100 $ orderPolygon $ convexHullSafe $ concat $ _rmBound rm ++ _rmPolys rm
        , _grDir   = snd . last $ _rmLinks rm
        , _grName  = _rmName rm
        }

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