Cleanup, improve auto wall rotate

src/Dodge/Placement/PlaceSpot.hs

@@ -1,12 +1,12 @@
---{-# LANGUAGE LambdaCase #-}
---{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
+-- {-# LANGUAGE LambdaCase #-}
+-- {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
 
 {- | deals with placement of objects within the world
  after they have had their coordinates set by the layout
 -}
 module Dodge.Placement.PlaceSpot (placeSpot) where
 
---import Control.Monad.State
+-- import Control.Monad.State
 import Control.Monad.Trans.State.Lazy
 import Data.Bifunctor
 import Data.Foldable
@@ -57,9 +57,7 @@ placePlainPSSpot w rid plmnt shift = case plmnt ^. plType of
         j <- x ^. plExternalID
         return $ gw & genPmnt . at j ?~ x
     recrPlace newplmnt w' =
-        placeSpot
-            rid
-            (w' & genRooms . ix rid . rmPmnts .:~ newplmnt)
+        placeSpot rid (w' & genRooms . ix rid . rmPmnts .:~ newplmnt)
 
 -- this should be tidied up
 placeSpotUsingRoomPos ::
@@ -94,7 +92,8 @@ placeSpotRoomRand ::
 placeSpotRoomRand rid i f plmnt w =
     let (ps, g) =
             runState
-                (_rmRandPSs (w ^?! genRooms . ix rid) !! i)
+                -- (_rmRandPSs (w ^?! genRooms . ix rid) !! i)
+                (w ^?! genRooms . ix rid . rmRandPSs . ix i)
                 $ w ^. gwWorld . randGen
      in placeSpot rid (w & gwWorld . randGen .~ g) (plmnt & plSpot .~ f ps)
 
@@ -102,46 +101,54 @@ placeSpotRoomRand rid i f plmnt w =
 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
+    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
+        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)
          in ( i
             , w
-                & gwWorld . cWorld . lWorld . floorItems . at i ?~ FlIt p rot
-                & gwWorld . cWorld . lWorld . items . at i
-                    ?~ ( itm & itID .~ NInt i
-                            & itLocation .~ OnFloor
-                       )
+                & gwWorld
+                . cWorld
+                . lWorld
+                . floorItems
+                . at i
+                ?~ FlIt p rot
+                & gwWorld
+                . cWorld
+                . lWorld
+                . items
+                . at i
+                ?~ (itm & itID .~ NInt i & itLocation .~ OnFloor)
             )
     PutCrit cr -> plNewUpID (gwWorld . cWorld . lWorld . creatures) crID (mvCr p rot cr) w
     PutForeground fs ->
         (0, w & gwWorld . cWorld . lWorld . foreShapes .:~ mvFS p rot fs)
     PutMachine pps mc mitm -> plMachine (map doShift pps) mc mitm p rot w
     PutLS ls -> plNewUpID (gwWorld . cWorld . lWorld . lightSources) lsID (mvLS p rot ls) w
-    RandPS _ -> error "RandPS should not be reachable here" --evaluateRandPS rid rgn ps w
+    RandPS _ -> error "RandPS should not be reachable here" -- evaluateRandPS rid rgn ps w
     PutDoor dr wl -> plDoor (dr & drZeroPos %~ pashift & drOnePos %~ pashift) wl w
     PutCoord cp -> plNewID (gwWorld . coordinates) (doShift cp) w
     PutBlock bl wl ps' ->
-        plBlock
-            (map doShift ps')
-            (bl & blPos %~ doShift & blDir .~ rot)
-            wl
-            w
+        plBlock (map doShift ps') (bl & blPos %~ doShift & blDir .~ rot) wl w
     PutLineBlock wl wdth a b -> plLineBlock wl wdth (doShift a) (doShift b) w
     PutWall qs wl -> (0, over gwWorld (placeWallPoly (map doShift qs) wl) w)
     PutNothing -> (0, w)
     PutID i -> (i, w)
     PutWorldUpdate f -> (0, w & f rid ps)
-    PutChasm ps' qs -> (0, placeChasm w rid ps' (map (map doShift) ps') 
-        (foldMap loopPairs (map (map doShift) qs)))
+    PutChasm ps' qs ->
+        ( 0
+        , placeChasm
+            w
+            rid
+            ps'
+            (map (map doShift) ps')
+            (foldMap (loopPairs . map doShift) qs)
+        )
     PutLabel{} -> (0, w)
   where
     p = _psPos ps
@@ -149,14 +156,15 @@ placeSpotID rid ps pt w = case pt of
     doShift = shiftPointBy (p, rot)
     pashift = compP2A (p, rot)
 
-placeChasm :: GenWorld -> Int -> [[Point2]] -> [[Point2]] -> [(Point2,Point2)] -> GenWorld
+placeChasm :: GenWorld -> Int -> [[Point2]] -> [[Point2]] -> [(Point2, Point2)] -> GenWorld
 placeChasm gw rid ps shiftps cfs =
-    gw & gwWorld . cWorld . chasms <>~ shiftps
+    gw
+        & gwWorld . cWorld . chasms <>~ shiftps
         & gwWorld . cWorld . cliffs <>~ cfs
         & genRooms . ix rid . rmPos %~ filter (\rp -> not $ any (pointInPoly (_rpPos rp)) ps)
         & gwWorld %~ f
   where
-    --f w = foldl' g w (loopPairs shiftps)
+    -- f w = foldl' g w (loopPairs shiftps)
     f w = foldl' g w cfs
     g w (x, y) = obstructPathsCrossing (S.singleton ChasmObstacle) x y w
 
@@ -171,19 +179,16 @@ addPane wl w l = insertWall (wl & wlLine .~ l & wlID .~ i) w
     i = IM.newKey $ w ^. cWorld . lWorld . walls
 
 mvProp :: Point2 -> Float -> Prop -> Prop
-mvProp p a = (prRot +~ a) . (prPos %~ ((p +.+) . rotateV a))
+mvProp p a = (prRot +~ a) . (prPos %~ ((p +) . rotateV a))
 
 mvButton :: Point2 -> Float -> Button -> Button
-mvButton p a = (btRot +~ a) . (btPos %~ ((p +.+) . rotateV a))
+mvButton p a = (btRot +~ a) . (btPos %~ ((p +) . rotateV a))
 
 mvCr :: Point2 -> Float -> Creature -> Creature
-mvCr p rot =
-    (crPos . _xy .~ p)
-        . (crOldPos . _xy .~ p)
-        . (crDir .~ rot)
+mvCr p rot = (crPos . _xy .~ p) . (crOldPos . _xy .~ p) . (crDir .~ rot)
 
 mvFS :: Point2 -> Float -> ForegroundShape -> ForegroundShape
-mvFS p a = (fsDir +~ a) . (fsPos %~ ((p +.+) . rotateV a))
+mvFS p a = (fsDir +~ a) . (fsPos %~ ((p +) . rotateV a))
 
 plMachine ::
     [Point2] ->
@@ -195,7 +200,8 @@ plMachine ::
     (Int, GenWorld)
 plMachine wallpoly mc mitm p rot gw =
     ( mcid
-    , gw & tolw . machines . at mcid ?~ themc
+    , gw
+        & tolw . machines . at mcid ?~ themc
         & gwWorld %~ placeMachineWalls (_mcMaterial mc) wallpoly mcid wlid
         & tolw %~ maybe id placeturretitm mitm
     )
@@ -215,8 +221,9 @@ plMachine wallpoly mc mitm p rot gw =
 placeMachineWalls :: Material -> [Point2] -> Int -> Int -> World -> World
 placeMachineWalls mat poly mcid = insertStructureWalls MachinePart baseWall poly mcid
   where
-    baseWall = defaultMachineWall & wlStructure . wsMachine .~ mcid
+    baseWall = defaultMachineWall 
+        & wlStructure . wsMachine .~ mcid
         & wlMaterial .~ mat
 
 mvLS :: Point2 -> Float -> LightSource -> LightSource
-mvLS x rot = lsParam . lsPos . _xy %~ ((+x) . rotateV rot)
+mvLS x rot = lsParam . lsPos . _xy %~ ((+ x) . rotateV rot)