Refactor, try to limit dependencies

2022-07-28 00:59:56 +01:00
parent 8aa5c17ab9
commit 160560af5f
418 changed files with 15104 additions and 13342 deletions
@@ -1,60 +1,59 @@
 --{-# LANGUAGE TupleSections #-}
-module Dodge.Layout 
-    ( generateLevelFromRoomList
-    ) where
-import Dodge.Zoning.Pathing
-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
+module Dodge.Layout (
+    generateLevelFromRoomList,
+) where

-import Data.Graph.Inductive (labNodes,labEdges)
-import Data.List (nubBy)
-import Data.Traversable
+import qualified Control.Foldl as L
 import Control.Lens
 import Data.Foldable
-import qualified Control.Foldl as L
-import Data.Maybe
 import Data.Function
+import Data.Graph.Inductive (labEdges, labNodes)
+import Data.List (nubBy)
+import Data.Maybe
+import Data.Tile
+import Data.Traversable
+import Dodge.Data.GenWorld
+import Dodge.Default.Wall
+import Dodge.GameRoom
+import Dodge.LevelGen.LevelStructure
+import Dodge.LevelGen.StaticWalls
+import Dodge.Path
+import Dodge.Placement.PlaceSpot
+import Dodge.Randify
+import Dodge.Room.Link
+import Dodge.ShiftPoint
+import Dodge.Wall.Zone
+import Dodge.Zoning.Pathing
+import Geometry
+import qualified IntMapHelp as IM
+import RandomHelp
+import Tile

 generateLevelFromRoomList :: IM.IntMap Room -> World -> GenWorld
-generateLevelFromRoomList gr' w = over gwWorld initWallZoning 
-    . over gwWorld randomCompass
-    . over gwWorld setupWorldBounds
-    . doAfterPlacements
-    . doInPlacements
-    . doOutPlacements
-    . doIndividualPlacements
-    . setFloors
-    . worldToGenWorld rs'
-    $ w & cWorld . walls .~ wallsFromRooms rs
-        & cWorld . gameRooms .~ gameRoomsFromRooms (IM.elems rs')
-        & cWorld . pathGraph .~ path
-        & cWorld . pnZoning   .~ foldl' (flip zonePn) mempty (labNodes path)
-        & cWorld . peZoning   .~ foldl' (flip zonePe) mempty (labEdges path)
+generateLevelFromRoomList gr' w =
+    over gwWorld initWallZoning
+        . over gwWorld randomCompass
+        . over gwWorld setupWorldBounds
+        . doAfterPlacements
+        . doInPlacements
+        . doOutPlacements
+        . doIndividualPlacements
+        . setFloors
+        . worldToGenWorld rs'
+        $ w & cWorld . walls .~ wallsFromRooms rs
+            & cWorld . gameRooms .~ gameRoomsFromRooms (IM.elems rs')
+            & cWorld . pathGraph .~ path
+            & cWorld . pnZoning .~ foldl' (flip zonePn) mempty (labNodes path)
+            & cWorld . peZoning .~ foldl' (flip zonePe) mempty (labEdges path)
  where
-    (_,path) = pairsToGraph pairPath'
+    (_, path) = pairsToGraph pairPath'
    pairPath = foldMap _rmPath rs
    pairPath' = fusePairs pairPath
    rs = map doRoomShift $ IM.elems rs'
-    rs'= mapM shuffleRoomPos gr' & evalState $ _randGen w
+    rs' = mapM shuffleRoomPos gr' & evalState $ _randGen w

 randomCompass :: World -> World
-randomCompass w = w & cWorld . cameraRot .~ (takeOne [0,0.5*pi,pi,1.5*pi] & evalState $ _randGen w)
+randomCompass w = w & cWorld . cameraRot .~ (takeOne [0, 0.5 * pi, pi, 1.5 * pi] & evalState $ _randGen w)

 putFloorTiles :: GenWorld -> GenWorld
 putFloorTiles gw = gw & gwWorld . cWorld . floorTiles .~ floorsFromGenWorld gw
@@ -70,7 +69,7 @@ setTiles gw = foldr setTile gw . reverse . IM.elems $ _genRooms gw

 setTile :: Room -> GenWorld -> GenWorld
 setTile r gw = case _rmFloor r of
-    Tiled {} -> gw
+    Tiled{} -> gw
    InheritFloor -> gw & genRooms . ix (fromJust (_rmMID r)) . rmFloor .~ Tiled [t & tilePoly .~ poly]
  where
    t = case _rmMParent r of
@@ -86,58 +85,65 @@ shuffleRoomPos rm = do
 doAfterPlacements :: GenWorld -> GenWorld
 doAfterPlacements gw = foldr doAfterPlacement gw (_genPlacements gw)

-doAfterPlacement :: [(Placement,Int)] -> GenWorld -> GenWorld
+doAfterPlacement :: [(Placement, Int)] -> GenWorld -> GenWorld
 doAfterPlacement pmntis gw = gRandify gw $ do
-    (pmnt,i) <- takeOne pmntis
-    let (newgw,rm) = fst $ placeSpot (gw,_genRooms gw IM.! i) pmnt
+    (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],GenWorld) -> GenWorld
-doInPlacements (im,w) = 
-    let (gw,rms) = mapAccumR (doRoomInPlacements im) w (_genRooms w)
-    in gw & genRooms .~ rms
+doInPlacements :: (IM.IntMap [Placement], GenWorld) -> GenWorld
+doInPlacements (im, w) =
+    let (gw, rms) = mapAccumR (doRoomInPlacements im) w (_genRooms w)
+     in gw & genRooms .~ rms

 doRoomInPlacements :: IM.IntMap [Placement] -> GenWorld -> Room -> (GenWorld, Room)
-doRoomInPlacements im w rm = foldr f (w,rm) $ _rmInPmnt rm
+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)
+    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) (_genRooms w)
-    in (pmnts,gw & genRooms .~ rms)
+doOutPlacements :: GenWorld -> (IM.IntMap [Placement], GenWorld)
+doOutPlacements w =
+    let ((pmnts, gw), rms) = mapAccumR doRoomOutPlacements (IM.empty, w) (_genRooms w)
+     in (pmnts, gw & genRooms .~ rms)

-doRoomOutPlacements :: (IM.IntMap [Placement], GenWorld) 
-    -> Room 
-    -> ( (IM.IntMap [Placement], GenWorld) , Room )
-doRoomOutPlacements imw r = foldr f ( imw, r ) $ _rmOutPmnt r
+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 )
+    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 (_genRooms gw)
-    in gw' & genRooms .~ rms
+doIndividualPlacements gw =
+    let (gw', rms) = mapAccumR doRoomPlacements gw (_genRooms gw)
+     in gw' & genRooms .~ rms

 doRoomPlacements :: GenWorld -> Room -> (GenWorld, Room)
-doRoomPlacements w rm = foldl' (\wr -> fst . placeSpot wr) (w,rm) $ _rmPmnts rm
+doRoomPlacements w rm = foldl' (\wr -> fst . placeSpot wr) (w, rm) $ _rmPmnts rm

 setupWorldBounds :: World -> World
-setupWorldBounds w = w & cWorld . worldBounds %~
-    ( (bdMinX .~ f minx)
-    . (bdMaxX .~ f maxx)
-    . (bdMinY .~ f miny)
-    . (bdMaxY .~ f maxy)
-    )
+setupWorldBounds w =
+    w & cWorld . worldBounds
+        %~ ( (bdMinX .~ f minx)
+                . (bdMaxX .~ f maxx)
+                . (bdMinY .~ f miny)
+                . (bdMaxY .~ f maxy)
+           )
  where
    f = fromMaybe 0
    ps = IM.map (fst . _wlLine) $ _walls (_cWorld 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
+    (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
@@ -149,36 +155,45 @@ initWallZoning w = foldl' (flip insertWallInZones) (w & cWorld . wlZoning .~ IM.
 --makePath = concatMap _rmPath . flatten

 wallsFromRooms :: [Room] -> IM.IntMap Wall
-wallsFromRooms = --    divideWalls .
-    IM.fromAscList 
-    . zipWith f [0..] 
-    . removeInverseWalls 
-    . foldl' (flip cutWalls) [] 
-    . concatMap _rmPolys
+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})
+    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
-    }
+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
-        ]
+    doubleShift p a =
+        map
+            doshift
+            [ p +.+ 10 *.* unitVectorAtAngle a
+            , p -.- 10 *.* unitVectorAtAngle a
+            ]
    filterUnusedLinks rp = case _rpLinkStatus rp of
        UnusedLink{} -> Just $ _rpPos rp
        _ -> Nothing
@@ -188,20 +203,20 @@ gameRoomFromRoom rm = GameRoom
        _ -> []
    undir rp = case _rpLinkStatus rp of
        UsedOutLink{} -> ma
-        UsedInLink{}  -> ma
+        UsedInLink{} -> ma
        _ -> Nothing
      where
-        ma = Just $ 0.5*pi + _rpDir rp + snd (_rmShift rm)
+        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 (rp : xs) = case _rpLinkStatus rp of
+        UsedInLink{} -> _rpDir rp + snd (_rmShift rm)
        _ -> getDir xs
    getDir _ = 0 -- fallback

-floorsFromRooms :: [Room] -> [(Point3,Point3)]
+floorsFromRooms :: [Room] -> [(Point3, Point3)]
 floorsFromRooms = concatMap (concatMap tileToRenderList . getTiles . _rmFloor . doRoomShift)

-floorsFromGenWorld :: GenWorld -> [(Point3,Point3)]
+floorsFromGenWorld :: GenWorld -> [(Point3, Point3)]
 floorsFromGenWorld = floorsFromRooms . IM.elems . _genRooms

 getTiles :: Floor -> [Tile]
@@ -216,7 +231,7 @@ getTiles fl = case fl of
 --      in  zipWith (\ x y -> wl & wlLine .~ (x,y) ) (init ps) (tail ps)

 --divideWallIn :: Wall -> IM.IntMap Wall -> IM.IntMap Wall
--divideWallIn wl wls = 
+--divideWallIn wl wls =
 --    let (wl':newWls) = divideWall wl
 --        k = IM.newKey wls
 --        newWls' = zipWith (\i w -> w {_wlID = i}) [k..] newWls
@@ -231,20 +246,20 @@ getTiles fl = case fl of

 --shiftRoomTree :: Tree Room -> Tree Room
 --shiftRoomTree (Node t []) = Node t []
--shiftRoomTree (Node t ts) = Node t 
--    $ zipWith (\l -> shiftRoomTree . applyToRoot (shiftRoomToLink l)) 
--    (_rmLinks 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) 
+--    zipWith (\l -> shiftRoomTreeConstruction . applyToRoot (shiftRoomBy l . f))
+--    (_rmLinks t)
 --    ts
--  where 
+--  where
 --    f r = shiftRoomBy ( V2 0 0 -.- rotateV (pi-a) p , 0) $ shiftRoomBy (V2 0 0,pi-a)  r
--      where 
+--      where
 --        (p,a) = last $ _rmLinks r

 --addTile :: Float -> Room -> Room