Cleanup some compiler warnings

This commit is contained in:
2024-10-22 10:33:14 +01:00
parent e2330618f2
commit c0b1092fb6
6 changed files with 155 additions and 190 deletions
+25 -18
View File
@@ -1,3 +1,4 @@
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
{- | deals with placement of objects within the world
after they have had their coordinates set by the layout
-}
@@ -5,7 +6,6 @@ module Dodge.Placement.PlaceSpot (
placeSpot,
) where
import NewInt
import Color
import Control.Lens
import Control.Monad.State
@@ -22,6 +22,7 @@ import Dodge.Placement.Shift
import Dodge.ShiftPoint
import Geometry
import qualified IntMapHelp as IM
import NewInt
import Picture
import System.Random
@@ -30,7 +31,8 @@ import System.Random
placeSpot :: (GenWorld, Room) -> Placement -> ((GenWorld, Room), [Placement])
placeSpot (w, rm) plmnt = case plmnt of
Placement{_plSpot = PSRoomRand i f} -> placeSpotRoomRand rm i f plmnt w
Placement{_plSpot = PSPos extract eff fallback} -> placeSpotUsingLink w rm plmnt extract eff fallback
Placement{_plSpot = PSPos extract eff fallback} ->
placeSpotUsingLink w rm plmnt extract eff fallback
Placement{} -> placePlainPSSpot w rm plmnt shift
PlacementUsingPos p subpl -> placeSpot (w, rm) (subpl (shiftPoint3By shift p))
RandomPlacement rplmnt -> placeRandomPlacement rplmnt w rm
@@ -39,14 +41,23 @@ placeSpot (w, rm) plmnt = case plmnt of
shift = _rmShift rm
placePickOne :: Int -> Placement -> Room -> GenWorld -> GenWorld
placePickOne i pl rm w = w & genPlacements %~ IM.insertWith (++) i [(pl, fromJust (_rmMID rm))]
placePickOne i pl rm = genPlacements %~ IM.insertWith (++) i [(pl, fromJust (_rmMID rm))]
placeRandomPlacement :: State StdGen Placement -> GenWorld -> Room -> ((GenWorld, Room), [Placement])
placeRandomPlacement ::
State StdGen Placement ->
GenWorld ->
Room ->
((GenWorld, Room), [Placement])
placeRandomPlacement rplmnt w rm = placeSpot (w & gwWorld . randGen .~ g, rm) plmnt'
where
(plmnt', g) = runState rplmnt (_randGen (_gwWorld w))
placePlainPSSpot :: GenWorld -> Room -> Placement -> DPoint2 -> ((GenWorld, Room), [Placement])
placePlainPSSpot ::
GenWorld ->
Room ->
Placement ->
DPoint2 ->
((GenWorld, Room), [Placement])
placePlainPSSpot w rm plmnt shift =
let (i, w') = placeSpotID (shiftPSBy shift (_plSpot plmnt)) (_plType plmnt) w
newplmnt = plmnt & plMID ?~ i
@@ -100,8 +111,12 @@ placeSpotID' ps pt w = case pt of
PutProp prp -> plNewUpID (cWorld . lWorld . props) prID (mvProp p rot prp) w
PutButton bt -> plNewUpID (cWorld . lWorld . buttons) btID (mvButton p rot bt) w
PutTerminal tm -> plNewUpID (cWorld . lWorld . terminals) tmID tm w
PutFlIt itm -> plNewUpID (cWorld . lWorld . floorItems . unNIntMap) (flItID . unNInt)
(createFlIt p rot itm) w
PutFlIt itm ->
plNewUpID
(cWorld . lWorld . floorItems . unNIntMap)
(flItID . unNInt)
(createFlIt p rot itm)
w
PutCrit cr -> plNewUpID (cWorld . lWorld . creatures) crID (mvCr p rot cr) w
PutForeground fs -> plNewUpID (cWorld . lWorld . foregroundShapes) fsID (mvFS p rot fs) w
PutDecoration pic -> plNewID (cWorld . lWorld . decorations) (shiftDec p rot pic) w
@@ -134,7 +149,7 @@ placeSpotID' ps pt w = case pt of
doShift = shiftPointBy (p, rot)
shiftDec :: Point2 -> Float -> Picture -> Picture
shiftDec p r pic = uncurryV translate p $ rotate r pic
shiftDec p r = uncurryV translate p . rotate r
evaluateRandPS :: State StdGen PSType -> PlacementSpot -> World -> (Int, World)
evaluateRandPS rgen ps w = placeSpotID' ps evaluatedType (set randGen g w)
@@ -147,12 +162,8 @@ evaluateRandPS rgen ps w = placeSpotID' ps evaluatedType (set randGen g w)
---- where
---- rmCrossPaths w = foldr (uncurry obstructPathsCrossing) w $ loopPairs ps
--placeWalls :: [Point2] -> Wall -> IM.IntMap Wall -> IM.IntMap Wall
--placeWalls qs wl wls = foldl' (addPane wl) wls pairs
-- where
-- (p:ps) = orderPolygon qs
-- pairs = zip (ps ++ [p]) (p:ps)
-- this function is the reason for the warning suppression
-- remove the warning suppression if it changes
placeWallPoly :: [Point2] -> Wall -> World -> World
placeWallPoly qs wl w = foldl' (addPane wl) w pairs
where
@@ -160,14 +171,10 @@ placeWallPoly qs wl w = foldl' (addPane wl) w pairs
pairs = zip (ps ++ [p]) (p : ps)
addPane :: Wall -> World -> (Point2, Point2) -> World
--addPane wl w l = w & walls %~ IM.insert wlid (wl { _wlLine = l, _wlID = wlid })
addPane wl w l =
w & plNew (cWorld . lWorld . walls) wlID (wl & wlLine .~ l)
& fst . uncurry (obstructPathsCrossing WallObstacle) l
-- where
-- wlid = IM.newKey (_walls w)
mvProp :: Point2 -> Float -> Prop -> Prop
mvProp p a = (prRot +~ a) . (prPos %~ ((p +.+) . rotateV a))