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,105 +1,123 @@
-{- | Creation, update and destruction of destructible walls.  -}
-module Dodge.Placement.PlaceSpot.Block 
-    ( plBlock
-    , plLineBlock
-    )
-    where
-import Dodge.Data
-import Dodge.Path
+-- | Creation, update and destruction of destructible walls.
+module Dodge.Placement.PlaceSpot.Block (
+    plBlock,
+    plLineBlock,
+) where
+
+import Control.Lens
+import qualified Data.IntSet as IS
+import Data.List
 import Dodge.Base
--import Dodge.Zone
+import Dodge.Data.World
+import Dodge.Path
 import Geometry
 import qualified IntMapHelp as IM

-import Control.Lens
-import Data.List
-import qualified Data.IntSet as IS
-
-plBlock 
-    :: [Point2]     -- ^ Block polygon
-    -> Block
-    -> Wall         -- ^ Base Pane
-    -> World 
-    -> (Int,World)
+plBlock ::
+    -- | Block polygon
+    [Point2] ->
+    Block ->
+    -- | Base Pane
+    Wall ->
+    World ->
+    (Int, World)
 plBlock [] _ _ _ = error "Trying to add a block with incomplete polygon"
-plBlock (p:ps) bl wl w = (,) blid $ w
-    & cWorld . blocks . at blid ?~ bl 
-        { _blID = blid
-        , _blWallIDs = IS.fromList is
-        , _blShadows = []
-        , _blFootprint = p:ps
-        }
-    & insertWalls blid wls
-  where 
+plBlock (p : ps) bl wl w =
+    (,) blid $
+        w
+            & cWorld . blocks . at blid
+                ?~ bl
+                    { _blID = blid
+                    , _blWallIDs = IS.fromList is
+                    , _blShadows = []
+                    , _blFootprint = p : ps
+                    }
+            & insertWalls blid wls
+  where
    blid = IM.newKey $ _blocks (_cWorld w)
-    lns = zip (p:ps) (ps ++ [p])
+    lns = zip (p : ps) (ps ++ [p])
    i = IM.newKey $ _walls (_cWorld w)
-    is = [i.. i + length lns-1]
-    wls = zipWith 
-        (\j ln -> wl & wlLine .~ ln & wlID .~ j & wlStructure .~ BlockPart blid) 
-        is 
-        lns 
-        
-{- | Splits a line into many four cornered blocks. -}
-plLineBlock 
-    :: Wall     -- ^ Base pane
-    -> Float
-    -> Point2   -- ^ Start point (symmetric)
-    -> Point2   -- ^ End point (symmetric)
-    -> World 
-    -> (Int, World)
-plLineBlock basePane blwidth a b gw = ( 0 
--    , foldr insertWall (insertBlocks gw) listWalls
-    , insertBlocks gw
+    is = [i .. i + length lns -1]
+    wls =
+        zipWith
+            (\j ln -> wl & wlLine .~ ln & wlID .~ j & wlStructure .~ BlockPart blid)
+            is
+            lns
+
+-- | Splits a line into many four cornered blocks.
+plLineBlock ::
+    -- | Base pane
+    Wall ->
+    Float ->
+    -- | Start point (symmetric)
+    Point2 ->
+    -- | End point (symmetric)
+    Point2 ->
+    World ->
+    (Int, World)
+plLineBlock basePane blwidth a b gw =
+    ( 0
+    , --    , foldr insertWall (insertBlocks gw) listWalls
+      insertBlocks gw
    )
-  where 
+  where
    depth = blwidth
    psOnLine = divideLineOddNumPoints blwidth a b
    halfBlockWidth = dist a b / fromIntegral (length psOnLine - 1)
    blockCenPs = snd $ evenOddSplit psOnLine
    numBlocks = length blockCenPs
-    is = [0.. numBlocks - 1]
+    is = [0 .. numBlocks - 1]
    cornerPoints = reverse $ rectWH halfBlockWidth depth -- goes clockwise around the block
-    cornersAt p = fmap ( (p +.+) . rotateV (argV (b -.- a)) ) cornerPoints
+    cornersAt p = fmap ((p +.+) . rotateV (argV (b -.- a))) cornerPoints
    linesAt p = loopPairs $ cornersAt p
    wlid = IM.newKey $ _walls (_cWorld gw)
    blid = IM.newKey $ _blocks (_cWorld gw)
-    insertBlock (i,p) = 
+    insertBlock (i, p) =
        insertWalls (i + blid) (makeWallAt p i)
-        . over (cWorld . blocks) (IM.insert (i+blid) Block 
-        { _blID = i + blid, _blWallIDs = IS.fromList $ ksAtI i
-        , _blHP = 1000, _blShadows = shadowsAt i
-        , _blDir = 0    -- THIS IS NOT SENSIBLE. TODO rethink block positioning
-        , _blFootprint = cornersAt p -- TODO check winding (clockwise, anticlockwise)
-        , _blObstructs = []
-        , _blMaterial = _wlMaterial basePane
-        , _blHeight   = 100
-        , _blPos = p, _blDraw = BlockDrawMempty }
-        )
+            . over
+                (cWorld . blocks)
+                ( IM.insert
+                    (i + blid)
+                    Block
+                        { _blID = i + blid
+                        , _blWallIDs = IS.fromList $ ksAtI i
+                        , _blHP = 1000
+                        , _blShadows = shadowsAt i
+                        , _blDir = 0 -- THIS IS NOT SENSIBLE. TODO rethink block positioning
+                        , _blFootprint = cornersAt p -- TODO check winding (clockwise, anticlockwise)
+                        , _blObstructs = []
+                        , _blMaterial = _wlMaterial basePane
+                        , _blHeight = 100
+                        , _blPos = p
+                        , _blDraw = BlockDrawMempty
+                        }
+                )
    insertBlocks = flip (foldr insertBlock) $ zip is blockCenPs
-    ksAtI i = map ( + (wlid + i*4) ) [0,1,2,3]
-    visibilityAt i 
-        | i == 0             = [False,True,True ,True]
-        | i == numBlocks - 1 = [True ,True,False,True]
-        | otherwise          = [False,True,False,True]
+    ksAtI i = map (+ (wlid + i * 4)) [0, 1, 2, 3]
+    visibilityAt i
+        | i == 0 = [False, True, True, True]
+        | i == numBlocks - 1 = [True, True, False, True]
+        | otherwise = [False, True, False, True]
    shadowsAt i
-        | i == 0             = ksAtI 1
+        | i == 0 = ksAtI 1
        | i == numBlocks - 1 = ksAtI $ numBlocks - 2
-        | otherwise          = ksAtI (i-1) ++ ksAtI (i+1)
+        | otherwise = ksAtI (i -1) ++ ksAtI (i + 1)
    makeWallAt p i = zipWith3 (makePane i) (visibilityAt i) (ksAtI i) (linesAt p)
-    makePane i visStatus k ps = basePane
-        {_wlID = k
-        ,_wlStructure = BlockPart $ i + blid
-        ,_wlLine = ps
-        ,_wlUnshadowed = visStatus
-        }
+    makePane i visStatus k ps =
+        basePane
+            { _wlID = k
+            , _wlStructure = BlockPart $ i + blid
+            , _wlLine = ps
+            , _wlUnshadowed = visStatus
+            }

 -- | Must be done after inserting the block
 insertWalls :: Int -> [Wall] -> World -> World
 insertWalls blid wls w = w' & cWorld . blocks . ix blid . blObstructs .~ concat paths
  where
-    (w',paths) = mapAccumR (flip insertWall) w wls
+    (w', paths) = mapAccumR (flip insertWall) w wls

-insertWall :: Wall -> World -> (World,[(Int,Int,PathEdge)])
-insertWall wl = uncurry (obstructPathsCrossing BlockObstacle) (_wlLine wl)
-    . (cWorld . walls . at (_wlID wl) ?~ wl)
+insertWall :: Wall -> World -> (World, [(Int, Int, PathEdge)])
+insertWall wl =
+    uncurry (obstructPathsCrossing BlockObstacle) (_wlLine wl)
+        . (cWorld . walls . at (_wlID wl) ?~ wl)
@@ -4,15 +4,12 @@ module Dodge.Placement.PlaceSpot.Block
    , plLineBlock
    )
    where
-import Dodge.Data
+import Dodge.Data.World
 import Dodge.Path
 import Dodge.Block.Debris
--import Dodge.LevelGen.LevelStructure
 import Dodge.Base
--import Dodge.Zone
 import Geometry
 import qualified IntMapHelp as IM
-
 import Control.Lens
 import qualified Data.IntSet as IS

@@ -1,118 +1,128 @@
--{-# LANGUAGE BangPatterns #-}
-module Dodge.Placement.PlaceSpot.TriggerDoor
-    ( plDoor
-    , plSlideDoor
-    , maybeClearDoorPaths
-    ) where
-import Dodge.Zoning.Wall
-import Dodge.Data
+module Dodge.Placement.PlaceSpot.TriggerDoor (
+    plDoor,
+    plSlideDoor,
+    maybeClearDoorPaths,
+) where
+
+import qualified Data.Graph.Inductive as FGL
+import qualified Data.IntSet as IS
+import Data.List
 import Dodge.Base
-import Dodge.Path
+import Dodge.Data.World
 import Dodge.Default.Door
 import Dodge.LevelGen.DoorPane
-import Picture
+import Dodge.Path
+import Dodge.Zoning.Wall
 import Geometry
 import qualified IntMapHelp as IM
 import LensHelp
--import Dodge.LevelGen.LevelStructure
+import Picture

--import Data.Maybe
-import Data.List
-import qualified Data.IntSet as IS
-import qualified Data.Graph.Inductive as FGL
-plDoor :: Color
-    -> EdgeObstacle
-    -> WdBl      -- ^ Opening condition
-    -> [(Point2,Point2)]   -- ^ Door positions, closed to open.
-                    -- Bumped out up and down by 9, not widened
-    -> World
-    -> (Int,World)
+plDoor ::
+    Color ->
+    EdgeObstacle ->
+    -- | Opening condition
+    WdBl ->
+    -- | Door positions, closed to open.
+    -- Bumped out up and down by 9, not widened
+    [(Point2, Point2)] ->
+    World ->
+    (Int, World)
 plDoor col eo cond pss gw = (drid, addWalls $ gw & cWorld . doors %~ addDoor) -- carefull with the ordering of addWalls
  where
    drid = IM.newKey $ _doors (_cWorld gw)
-    addDoor = IM.insert drid $ defaultDoor
-        { _drID = drid
-        , _drWallIDs = IS.fromList wlids
-        , _drStatus = DoorInt 0
-        , _drTrigger = cond
-        , _drMech   = DrWdMechanismStepwise nsteps wlids pss
-        , _drPos = head pss
-        , _drOpenPos = head pss
-        , _drClosePos = last pss
-        , _drObstacleType = eo
-        }
+    addDoor =
+        IM.insert drid $
+            defaultDoor
+                { _drID = drid
+                , _drWallIDs = IS.fromList wlids
+                , _drStatus = DoorInt 0
+                , _drTrigger = cond
+                , _drMech = DrWdMechanismStepwise nsteps wlids pss
+                , _drPos = head pss
+                , _drOpenPos = head pss
+                , _drClosePos = last pss
+                , _drObstacleType = eo
+                }
    nsteps = length pss - 1
    wlids = take 4 [IM.newKey $ _walls (_cWorld gw) ..]
    wlps' = uncurry (rectanglePairs 9) $ head pss
    addWalls w' = foldl' (addDoorWall eo drid $ switchWallCol col) w' $ zip wlids wlps'

-addDoorWall :: EdgeObstacle -> Int -> Wall -> World -> (Int,(Point2,Point2)) -> World
-addDoorWall eo drid wl w (wlid,wlps) = w' 
-    & cWorld . walls %~ IM.insert wlid wl
-        { _wlLine = wlps
-        , _wlID = wlid
-        , _wlStructure = DoorPart drid
-        }
-    & cWorld . doors . ix drid . drObstructs .++~ es
+addDoorWall :: EdgeObstacle -> Int -> Wall -> World -> (Int, (Point2, Point2)) -> World
+addDoorWall eo drid wl w (wlid, wlps) =
+    w'
+        & cWorld . walls
+            %~ IM.insert
+                wlid
+                wl
+                    { _wlLine = wlps
+                    , _wlID = wlid
+                    , _wlStructure = DoorPart drid
+                    }
+        & cWorld . doors . ix drid . drObstructs .++~ es
  where
-    (w',es) = uncurry (obstructPathsCrossing eo) wlps w
+    (w', es) = uncurry (obstructPathsCrossing eo) wlps w

-maybeClearDoorPaths :: EdgeObstacle -> [(Int,Int,PathEdge)] -> World -> World
+maybeClearDoorPaths :: EdgeObstacle -> [(Int, Int, PathEdge)] -> World -> World
 maybeClearDoorPaths eo es w = foldl' (maybeClearDoorPath eo) w es

-maybeClearDoorPath :: EdgeObstacle -> World -> (Int,Int,PathEdge) -> World
-maybeClearDoorPath eo w (x,y,pe)
-    | not . null $ overlapSegWalls (_peStart pe) (_peEnd pe) $ wlsNearSeg (_peStart pe) (_peEnd pe) w 
-        = w & cWorld . pathGraph %~ FGL.insEdge (x,y,pe & peObstacles . at eo ?~ ()) . FGL.delEdge (x,y)
-    | otherwise 
-        = w & cWorld . pathGraph %~ FGL.insEdge (x,y,pe & peObstacles . at eo .~ Nothing) . FGL.delEdge (x,y) 
+maybeClearDoorPath :: EdgeObstacle -> World -> (Int, Int, PathEdge) -> World
+maybeClearDoorPath eo w (x, y, pe)
+    | not . null $ overlapSegWalls (_peStart pe) (_peEnd pe) $ wlsNearSeg (_peStart pe) (_peEnd pe) w =
+        w & cWorld . pathGraph %~ FGL.insEdge (x, y, pe & peObstacles . at eo ?~ ()) . FGL.delEdge (x, y)
+    | otherwise =
+        w & cWorld . pathGraph %~ FGL.insEdge (x, y, pe & peObstacles . at eo .~ Nothing) . FGL.delEdge (x, y)

-plSlideDoor 
-    :: Door 
-    -> Wall
-    -> EdgeObstacle
-    -> Float
-    -> Point2 
-    -> Point2 
-    -> World
-    -> (Int, World)
-plSlideDoor dr wl eo shiftOffset a b gw 
-    = (drid, addDoorWalls $ gw & cWorld . doors %~ addDoor)
+plSlideDoor ::
+    Door ->
+    Wall ->
+    EdgeObstacle ->
+    Float ->
+    Point2 ->
+    Point2 ->
+    World ->
+    (Int, World)
+plSlideDoor dr wl eo shiftOffset a b gw =
+    (drid, addDoorWalls $ gw & cWorld . doors %~ addDoor)
  where
    drid = IM.newKey $ _doors (_cWorld gw)
-    addDoor = IM.insert drid $ dr
-        { _drID = drid
-        , _drWallIDs = IS.fromList wlids
-        , _drStatus = DoorClosed
-        , _drMech   = DoorMechanism
-        , _drPos = (a,b)
-        , _drOpenPos = (shiftLeft a,shiftLeft b)
-        , _drClosePos = (a,b)
-        , _drObstacleType = eo
-        }
+    addDoor =
+        IM.insert drid $
+            dr
+                { _drID = drid
+                , _drWallIDs = IS.fromList wlids
+                , _drStatus = DoorClosed
+                , _drMech = DoorMechanism
+                , _drPos = (a, b)
+                , _drOpenPos = (shiftLeft a, shiftLeft b)
+                , _drClosePos = (a, b)
+                , _drObstacleType = eo
+                }
    addDoorWalls w' = foldl' (addDoorWall eo drid wl) w' $ zip wlids pairs
    pairs = rectanglePairs 9 a b
-    shiftLeft  = (+.+ (a -.- b +.+ shiftOffset *.* normalizeV (b -.- a)))
+    shiftLeft = (+.+ (a -.- b +.+ shiftOffset *.* normalizeV (b -.- a)))
    wlids = take 4 [IM.newKey $ _walls (_cWorld gw) ..]
+
 -- old code that may help with pathing
 --import Dodge.LevelGen.Pathing
 --import Data.Graph.Inductive hiding ((&))
 --addButtonDoor :: Color -> Point2 -> Float -> Point2 -> Point2 -> Float -> World -> (Int, World)
--addButtonDoor c btp btr a b speed w 
+--addButtonDoor c btp btr a b speed w
 --    = (,) 0
--    . over buttons (IM.insert bid bt) 
+--    . over buttons (IM.insert bid bt)
 --    $ set pathPoints (foldr insertPoint IM.empty (labNodes newGraph))
 --    $ set pathGraph newGraph
 --    $ set pathGraphP newGraphPairs
 --    $ snd (placeSlideDoor False c cond a b speed w)
--  where 
+--  where
 --    bid = IM.newKey $ _buttons w
 --    cond w' = BtNoLabel == _btState (_buttons w' IM.! bid)
 --    bt = (makeButton c eff) {_btPos = btp, _btRot = btr, _btID = bid}
--    (newGraphPairs,removedPairs) = partition (isNothing . uncurry (intersectSegSeg a b)) 
+--    (newGraphPairs,removedPairs) = partition (isNothing . uncurry (intersectSegSeg a b))
 --                                             $ _pathGraphP w
 --    newGraph = pairsToGraph dist newGraphPairs
 --    insertPoint  pp@(_,V2 x y) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp]
--    eff w' = over pathGraphP (removedPairs ++) 
+--    eff w' = over pathGraphP (removedPairs ++)
 --             . over pathGraph (flip run_ $ insMapEdgesM $ map f removedPairs) $ w'
 --    f (x,y) = (x,y,dist x y)