justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Cleanup, improve auto wall rotate

Browse Source
This commit is contained in:
justin
2026-03-24 11:28:11 +00:00
parent be2f7160ba
commit 32f1740577
25 changed files with 226 additions and 252 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Placement/Instance/Button.hs
+12 -16
View File
@@ -10,6 +10,7 @@ import Dodge.LightSource
import Dodge.Placement.Instance.LightSource
import Dodge.PlacementSpot
import Geometry
import Shape
triggerSwitchSPic :: Color -> Color -> PlacementSpot -> Placement
triggerSwitchSPic c1 c2 ps = psPtCont ps (PutTrigger False) $
@@ -19,7 +20,8 @@ triggerSwitchSPic c1 c2 ps = psPtCont ps (PutTrigger False) $
ps
( PutButton
( makeSwitch
c1 c2
c1
c2
(SetTrigger True $ trigid tp)
(SetTrigger False $ trigid tp)
)
@@ -50,14 +52,7 @@ triggerSwitch col ps = psPtCont ps (PutTrigger False) $
Just $
pContID
ps
( PutButton
( makeSwitch
col
col
(SetTrigger True $ trigid tp)
(SetTrigger False $ trigid tp)
)
)
(PutButton (makeSwitch col col (SetTrigger True $ trigid tp) (SetTrigger False $ trigid tp)))
(const Nothing)
where
trigid tp = fromJust $ _plMID tp
@@ -65,14 +60,14 @@ triggerSwitch col ps = psPtCont ps (PutTrigger False) $
putLitButOnPos :: Color -> PlacementSpot -> (Placement -> Maybe Placement) -> Placement
putLitButOnPos col theps subpl =
plSpot .~ theps $
mntLSOn aShape (Just col) ls 0 (V3 0 (-40) 40) $
\plmnt ->
mntLSOn shp ls 0 (V3 0 (-40) 40) $
\pmnt ->
jps0'
(PutButton (makeButton col (changeLight . fromJust $ _plMID plmnt)){_btPos = V2 0 (-1), _btRot = pi})
(PutButton (makeButton col (changeLight $ pmnt ^?! plMID . _Just) & btPos .~ V2 0 (-1) & btRot .~ pi))
subpl
<&> plSpot
.~ _plSpot plmnt
<&> plSpot .~ _plSpot pmnt
where
shp = fmap (fmap $ colorSH col) aShape
changeLight = SetLSCol (V3 0 0.5 0)
ls = lsColPosRad (V3 0.5 0 0) (V3 0 0 50) 50
@@ -107,7 +102,7 @@ putLitButOnPosExtTrig' col thePS cnt =
psPtCont thePS (PutTrigger False) $
\tp -> Just $
plSpot .~ _plSpot tp $
mntLSOn aShape (Just col) ls 0 (V3 0 (-40) 40) $
mntLSOn shp ls 0 (V3 0 (-40) 40) $
\plmnt ->
jps0'
( PutButton
@@ -118,8 +113,9 @@ putLitButOnPosExtTrig' col thePS cnt =
)
(cnt tp plmnt)
<&> plSpot
.~ _plSpot plmnt
.~ _plSpot plmnt
where
shp = fmap (fmap $ colorSH col) aShape
trigid tp = fromJust $ _plMID tp
oneff = SetTrigger True
changeLight = SetLSCol (V3 0 0.5 0)
src/Dodge/Placement/Instance/Door.hs
+1 -1
View File
@@ -74,6 +74,6 @@ putAutoDoor a b = Placement (PS 0 0) (PutCoord a) Nothing Nothing $ \_ apl ->
a
b
( defaultDoor
& drTrigger .~ (WdBlCrFilterNearPoint 40 (0.5 *^ (x + y)) CrOpenAutoDoor)
& drTrigger .~ WdBlCrFilterNearPoint 40 (0.5 *^ (x + y)) CrOpenAutoDoor
& drUpdate .~ DoorLerpWithTimer 0 3
)
src/Dodge/Placement/Instance/LightSource.hs
+5 -6
View File
@@ -36,15 +36,14 @@ mntLSOn ::
-- | function describing the mount shape
(Point2 -> Point3 -> Shape) ->
-- | describing a possible color override for the shape
Maybe Color ->
LightSource ->
Point2 ->
Point3 ->
(Placement -> Maybe Placement) ->
Placement
mntLSOn shapeF mcol ls wallp lsp@(V3 lx ly _) =
mntLSOn shapeF ls wallp lsp@(V3 lx ly _) =
ps0jPushPS (PutLabel "light") .
ps0jPushPS (putShape . setCol $ shapeF wallp lsp)
ps0jPushPS (putShape $ shapeF wallp lsp)
--ps0j (PutLabel "light") .
--ps0j (putShape . setCol $ shapeF wallp lsp)
. pt0 (PutLS $ ls & lsParam . lsPos .~ lsp')
@@ -52,7 +51,7 @@ mntLSOn shapeF mcol ls wallp lsp@(V3 lx ly _) =
lsp' = lsp -.-.- V3 x y 1
-- hack! perturb the light position
V2 x y = rotateV 1 . (0.1 *.*) . normalizeV $ wallp -.- V2 lx ly
setCol = maybe id colorSH mcol
-- setCol = maybe id colorSH mcol
iShape :: Point2 -> Point3 -> Shape
iShape wp (V3 x y z) = thinHighBar z wp (V2 x y)
@@ -107,7 +106,7 @@ vShape wallpos (V3 x y z) =
wallposDown = wallpos -.- n
mntLS :: (Point2 -> Point3 -> Shape) -> Point2 -> Point3 -> Placement
mntLS shp wallp lampp = mntLSOn shp Nothing defaultLS wallp lampp (const Nothing)
mntLS shp wallp lampp = mntLSOn shp defaultLS wallp lampp (const Nothing)
where
defaultLS = LS 0 $ LSParam 0 300 0.6
@@ -152,7 +151,7 @@ mntLightLnkCond ps = do
return $ mntLSCond (fmap (fmap $ colorSH black) shp) ps
mntLightLnkShape :: (Point2 -> Point3 -> Shape) -> PlacementSpot -> Placement
mntLightLnkShape shp ps = mntLSCond (fmap (fmap $ colorSH black) shp) ps
mntLightLnkShape shp = mntLSCond (fmap (fmap $ colorSH black) shp)
mntLightLnkCond' :: PlacementSpot -> Placement
mntLightLnkCond' = mntLSCond (fmap (fmap $ colorSH black) vShape)
src/Dodge/Placement/PlaceSpot.hs
+47 -40
View File
@@ -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)