loop/src/Dodge/Layout.hs

{-# LANGUAGE TupleSections #-}
module Dodge.Layout 
    where
import Dodge.Data
import Dodge.LevelGen
import Dodge.LevelGen.StaticWalls
--import Dodge.LevelGen.Data
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 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
import qualified Control.Foldl as L
import Data.Maybe

generateLevelFromRoomList :: State StdGen [Room] -> World -> World
generateLevelFromRoomList gr w 
    = updateWallZoning 
    . setupWorldBounds
--    . initializeStaticWalls
--    . setupForegroundEdgeVerxs
    . flip (foldr $ flip placeSpot') plmnts
--    . addRoomPolyDecorations rs
--    . addRoomLinkDecorations rs
    $ 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 ,) (_rmPS r)) rs
    rs = zipWith addTile zs rs'
    zs = map fromIntegral $ randomRs (0,63::Int) $ _randGen w
    rs' = evalState gr $ _randGen w

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 . 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
        , _grViewpointsEx = 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