Cleanup

2025-10-03 20:14:41 +01:00
parent 2d44809900
commit cba3ca784a
13 changed files with 181 additions and 193 deletions
@@ -6,12 +6,12 @@
 -}
 module Dodge.Placement.PlaceSpot (placeSpot) where

-import Data.Maybe
 import Color
 import Control.Monad.State
 import Data.Bifunctor
 import Data.Foldable
 import qualified Data.IntSet as IS
+import Data.Maybe
 import Dodge.Base.NewID
 import Dodge.Data.GenWorld
 import Dodge.Path
@@ -23,6 +23,7 @@ import Geometry
 import qualified IntMapHelp as IM
 import LensHelp
 import NewInt
+
 --import System.Random

 -- when placing a placement, we update the world and the room and assign an id
@@ -40,14 +41,17 @@ placeSpot rid w plmnt = case plmnt of

 placePlainPSSpot :: GenWorld -> Int -> Placement -> DPoint2 -> GenWorld
 placePlainPSSpot w rid plmnt shift = case plmnt ^. plType of
-    RandPS rgn -> 
+    RandPS rgn ->
        let (x, g) = runState rgn (w ^. gwWorld . randGen)
-        in placePlainPSSpot (w & gwWorld . randGen .~ g) rid (plmnt & plType .~ x) shift
+         in placePlainPSSpot (w & gwWorld . randGen .~ g) rid (plmnt & plType .~ x) shift
    _ ->
        let (i, w') = placeSpotID rid (shiftPSBy shift (_plSpot plmnt)) (_plType plmnt) w
            newplmnt = plmnt & plMID ?~ i
-            gw = maybe (w' & genRooms . ix rid . rmPmnts .:~ newplmnt) 
-                (recrPlace newplmnt w') (_plIDCont plmnt w' newplmnt)
+            gw =
+                maybe
+                    (w' & genRooms . ix rid . rmPmnts .:~ newplmnt)
+                    (recrPlace newplmnt w')
+                    (_plIDCont plmnt w' newplmnt)
         in f newplmnt gw
  where
    f x gw = fromMaybe gw $ do
@@ -65,7 +69,11 @@ placeSpotUsingLink ::
    Maybe Placement ->
    GenWorld
 placeSpotUsingLink w rid plmnt extract eff fallback = case searchedPoss (w ^?! genRooms . ix rid . rmPos) of
-    Just (ps, rmposs) -> placeSpot rid (w & genRooms . ix rid %~ eff (head rmposs) . (rmPos .~ rmposs)) (plmnt & plSpot .~ ps)
+    Just (ps, rmposs) ->
+        placeSpot
+            rid
+            (w & genRooms . ix rid %~ eff (head rmposs) . (rmPos .~ rmposs))
+            (plmnt & plSpot .~ ps)
    Nothing -> case fallback of
        Nothing -> w
        Just plmnt' -> placeSpot rid w plmnt'
@@ -86,15 +94,18 @@ placeSpotRoomRand rid i f plmnt w =
    let (ps, g) = runState (_rmRandPSs (w ^?! genRooms . ix rid) !! i) $ w ^. gwWorld . randGen
     in placeSpot rid (w & gwWorld . randGen .~ g) (plmnt & plSpot .~ f ps)

-
 -- the Int here is some id that is assigned when the placement is placed
 placeSpotID :: Int -> PlacementSpot -> PSType -> GenWorld -> (Int, GenWorld)
 placeSpotID rid ps pt w = case pt of
    PutTrigger cnd -> plNewID (gwWorld . cWorld . lWorld . triggers) cnd w
    PutMod mdi -> plNewUpID (gwWorld . cWorld . lWorld . modifications) mdID mdi w
    PutProp prp -> plNewUpID (gwWorld . cWorld . lWorld . props) prID (mvProp p rot prp) w
-    PutButton bt -> plNewUpID (gwWorld . cWorld . lWorld . buttons) btID 
-        (mvButton p rot bt) w
+    PutButton bt ->
+        plNewUpID
+            (gwWorld . cWorld . lWorld . buttons)
+            btID
+            (mvButton p rot bt)
+            w
    PutTerminal tm -> plNewUpID (gwWorld . cWorld . lWorld . terminals) tmID tm w
    PutFlIt itm ->
        let i = IM.newKey (w ^. gwWorld . cWorld . lWorld . items)
@@ -107,8 +118,12 @@ placeSpotID rid ps pt w = case pt of
                       )
            )
    PutCrit cr -> plNewUpID (gwWorld . cWorld . lWorld . creatures) crID (mvCr p rot cr) w
-    PutForeground fs -> plNewUpID (gwWorld . cWorld . lWorld . foregroundShapes) fsID 
-        (mvFS p rot fs) w
+    PutForeground fs ->
+        plNewUpID
+            (gwWorld . cWorld . lWorld . foregroundShapes)
+            fsID
+            (mvFS p rot fs)
+            w
    PutMachine pps mc wl mitm -> plMachine (map doShift pps) mc wl mitm p rot w
    PutLS ls -> plNewUpID (gwWorld . cWorld . lWorld . lightSources) lsID (mvLS p' rot ls) w
    PutPPlate pp -> plNewUpID (gwWorld . cWorld . lWorld . pressPlates) ppID (mvPP p rot pp) w
@@ -129,16 +144,16 @@ placeSpotID rid ps pt w = case pt of
    PutID i -> (i, w)
    PutWorldUpdate f -> (0, w & f rid ps)
    PutChasm ps' -> (0, w & gwWorld . cWorld . chasms .:~ map doShift ps')
-    PutLabel {} -> (0, w)
+    PutLabel{} -> (0, w)
  where
    p@(V2 px py) = _psPos ps
    p' = V3 px py 0
    rot = _psRot ps
    doShift = shiftPointBy (p, rot)

--evaluateRandPS 
+--evaluateRandPS
 --    :: Int -> State StdGen PSType -> PlacementSpot -> GenWorld -> (Int, GenWorld)
--evaluateRandPS rid rgen ps w = placeSpotID rid ps evaluatedType 
+--evaluateRandPS rid rgen ps w = placeSpotID rid ps evaluatedType
 --    $ set (gwWorld . randGen) g w
 --  where
 --    (evaluatedType, g) = runState rgen (_randGen $ _gwWorld w)
@@ -177,8 +192,15 @@ plMachine wallpoly mc wl = \case
    Nothing -> plMachine' wallpoly mc wl
    Just itm -> plTurret wallpoly mc wl itm

-plTurret :: [Point2] -> Machine -> Wall -> Item -> Point2 -> Float -> GenWorld 
-    -> (Int, GenWorld)
+plTurret ::
+    [Point2] ->
+    Machine ->
+    Wall ->
+    Item ->
+    Point2 ->
+    Float ->
+    GenWorld ->
+    (Int, GenWorld)
 plTurret wallpoly mc wl itm p rot gw =
    ( mcid
    , gw & gwWorld . cWorld . lWorld . machines %~ addMc
@@ -215,8 +237,8 @@ plMachine' wallpoly mc wl p rot gw =
    addMc = IM.insert mcid (mc{_mcPos = p, _mcDir = rot, _mcID = mcid, _mcWallIDs = wlids})

 -- TODO correctly remove/shift pathfinding lines (removePathsCrossing)
-placeMachineWalls 
-    :: Wall -> Color -> [Point2] -> Int -> Int -> IM.IntMap Wall -> IM.IntMap Wall
+placeMachineWalls ::
+    Wall -> Color -> [Point2] -> Int -> Int -> IM.IntMap Wall -> IM.IntMap Wall
 placeMachineWalls wl col poly mcid wlid = flip (foldr f) $ zip [wlid ..] $ loopPairs poly
  where
    f (wid, l) = IM.insert wid baseWall{_wlID = wid, _wlLine = l}
@@ -31,7 +31,7 @@ roomGlassOctogon x =
                ]
            , _rmLinks = lnks'
            , _rmPath =
-                linksAndPath'
+                linksGridToPath
                    lnks'
                    [ (V2 0 x, V2 0 (- (x + 40)))
                    , (V2 0 (- (x + 40)), V2 0 x)
@@ -2,7 +2,6 @@ module Dodge.Room.CheckConsistency where

 import Dodge.Data.GenWorld
 import Dodge.Graph
-import Dodge.RoomLink

 linksOnPath :: Room -> Bool
 linksOnPath r = all pointOnPath linkPoints
@@ -29,6 +29,7 @@ roomNgon n x = do
    rot = 2 * pi / fromIntegral n
    rots = map ((rot *) . fromIntegral) [0 .. n -1]
    poly = polyOrthDist n x
+    path1 = polyOrthDist n (x-10)
    lnks =
        sortOn ((\(V2 a b) -> (negate b, a)) . fst . snd)
            . zip [0 ..]
@@ -1,6 +1,6 @@
 module Dodge.Room.Path (
    gridPoints,
-    linksAndPath',
+    linksGridToPath,
    makeGrid,
    createPathGrid,
    gridPoints'',
@@ -14,17 +14,14 @@ import Data.Maybe
 import qualified Data.Set as S
 import Dodge.Data.GenWorld
 import Dodge.LevelGen.StaticWalls
-import Dodge.RoomLink
 import Geometry
 import Grid

 createPathGrid :: Room -> Room
-createPathGrid rm =
-    rm
-        { _rmPath = linksAndPath' (_rmLinks rm) filterGrid
-        }
+createPathGrid rm = rm & rmPath .~ linksGridToPath (_rmLinks rm) filterGrid
  where
-    filterGrid = filter (\p -> pairInPolys (_rmPolys rm) p && testCrossWalls outerWalls p) grid
+    filterGrid = filter 
+        (\p -> pairInPolys (_rmPolys rm) p && testCrossWalls outerWalls p) grid
    grid = fromMaybe [] $ shiftedGrid <$> minx <*> maxx <*> miny <*> maxy
    outerWalls = foldr cutPoly [] $ _rmPolys rm
    outerPoints = map fst outerWalls
@@ -36,17 +33,10 @@ createPathGrid rm =
            <*> L.premap sndV2 L.minimum
            <*> L.premap sndV2 L.maximum

--linksAndPath :: [(Point2, Float)] -> [(Point2, Point2)] -> S.Set (Point2, Point2)
--linksAndPath lnks subpth = S.fromList subpth <> foldMap linkClosest lnks
--  where
--    linkClosest (p, _) = doublePairSet (p, minimumBy (compare `on` dist p) $ map fst subpth)
-
-linksAndPath' :: [RoomLink] -> [(Point2, Point2)] -> S.Set (Point2, Point2)
-linksAndPath' lnks subpth = S.fromList subpth 
-    <> foldMap (linkClosest . (^. rlPos) ) lnks
+linksGridToPath :: [RoomLink] -> [(Point2, Point2)] -> S.Set (Point2, Point2)
+linksGridToPath lnks subpth = S.fromList subpth <> foldMap (linkClosest . (^. rlPos)) lnks
  where
    linkClosest p = doublePairSet (p, minimumBy (compare `on` dist p) $ map fst subpth)
--linksAndPath' = linksAndPath . map lnkPosDir

 testCrossWalls :: [(Point2, Point2)] -> (Point2, Point2) -> Bool
 testCrossWalls wls (a, b) = not $ any (isJust . uncurry (intersectSegSeg a b)) wls
@@ -95,7 +95,8 @@ roomRect x y xn yn =
    m edge edgefrom1 edgefrom2 =
        zipWith (lnkBothAnd (OnEdge edge) edgefrom1 edgefrom2) [0 ..]
            . zipCountDown
-    pth = linksAndPath' lnks $ map (bimap (+.+ V2 20 20) (+.+ V2 20 20)) (makeGrid xd xn yd yn)
+    pth = linksGridToPath lnks 
+        $ map (bimap (+.+ V2 20 20) (+.+ V2 20 20)) (makeGrid xd xn yd yn)
    makeonpos (p, a) = RoomPos p 0 (S.singleton $ RoomPosOnPath $ makerpedges a) 
        NotLink mempty
    makerpedges (a, b) =
@@ -5,7 +5,6 @@ module Dodge.RoomLink (
    inLink,
    restrictLinkType,
    overLnkType,
--    lnkPosDir,
    overLnkPosDir,
    toBothLnk,
    rmInLinks,
@@ -113,9 +112,6 @@ overLnkType lt f = rmLinks %~ g
 rlPosDir :: RoomLink -> (Point2, Float)
 rlPosDir rl = (_rlPos rl, _rlDir rl)

-lnkPosDir :: RoomLink -> (Point2, Float)
-lnkPosDir rl = (_rlPos rl, _rlDir rl)
-
 overLnkPosDir :: ((Point2, Float) -> (Point2, Float)) -> RoomLink -> RoomLink
 overLnkPosDir f rl = rl & rlPos .~ p & rlDir .~ a
  where
@@ -49,7 +49,8 @@ posRms ::
    IO (Maybe PosRooms)
 posRms prs roomi [] st = case st of
    Empty -> return $ Just $ prs & prRooms .:~ roomi
-    Node nextroomi ts Seq.:<| tseq -> posRms (prs & prRooms .:~ roomi) nextroomi (zipCount ts) tseq
+    Node nextroomi ts Seq.:<| tseq 
+        -> posRms (prs & prRooms .:~ roomi) nextroomi (zipCount ts) tseq
    _ -> error "unexpected outcome in posRms"
 posRms prs parenti@(parent, _) ((numChild, t@(Node childi _)) : its) tseq = do
    printInfoCheckNum parenti numChild childi