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

Start cleanup of room in-links

Browse Source
This commit is contained in:
justin
2022-03-05 01:09:19 +00:00
parent 8fa6bbfe29
commit 0c580e63a4
11 changed files with 67 additions and 90 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Placement/Instance/LightSource.hs
-1
View File
@@ -28,7 +28,6 @@ mntLSOn shapeF mcol ls wallp lsp@(V3 lx ly _)
V2 x y = rotateV 1 . (0.1 *.*) . normalizeV $ wallp -.- V2 lx ly
setCol = maybe id colorSH mcol
iShape :: Point2 -> Point3 -> Shape
iShape wp (V3 x y z) = thinHighBar z wp (V2 x y)
src/Dodge/Placement/PlaceSpot.hs
+9 -9
View File
@@ -87,20 +87,20 @@ placeSpotRoomRand rm i f plmnt w =
-- the Int here is some id that is assigned when the placement is placed
placeSpotID :: PlacementSpot -> PSType -> GenWorld -> (Int, GenWorld)
placeSpotID ps pt w = case pt of
PutTrigger cnd -> placeNewInto triggers cnd w
PutTrigger cnd -> plNewID triggers cnd w
PutMod mdi -> plNewUpID modifications mdID mdi w
PutProp prp -> plNewUpID props pjID (mvProp p rot prp) w
PutButton bt -> plNewUpID buttons btID (mvButton p rot bt) w
PutFlIt itm -> plNewUpID floorItems flItID (createFlIt p rot itm) w
PutCrit cr -> plNewUpID creatures crID (mvCr p rot cr) w
PutMachine col pps mc -> placeMachine col (map doShift pps) mc p rot w
PutMachine col pps mc -> plMachine col (map doShift pps) mc p rot w
PutLS ls -> plNewUpID lightSources lsID (mvLS p' rot ls) w
PutPPlate pp -> plNewUpID pressPlates ppID (mvPP p rot pp) w
RandPS rgn -> evaluateRandPS rgn ps w
PutDoor col f pss -> placeDoor col f (map (bimap doShift doShift) pss) w
PutCoord cp -> placeNewInto coordinates (doShift cp) w
PutDoor col f pss -> plDoor col f (map (bimap doShift doShift) pss) w
PutCoord cp -> plNewID coordinates (doShift cp) w
PutSlideDr pth col f a b spd
-> placeSlideDoor pth col f (doShift a) (doShift b) spd w
-> plSlideDoor pth col f (doShift a) (doShift b) spd w
PutBlock bm hp hps wl ps'
-> placeBlock (map doShift ps') hp wl hps bm w
PutLineBlock wl bm wdth dpth a b -> placeLineBlock wl bm wdth dpth (doShift a) (doShift b) w
@@ -142,11 +142,11 @@ addPane wl l wls = IM.insert wlid (wl { _wlLine = l, _wlID = wlid }) wls
-- | generalised way of putting a new item into a lensed intmap, returning the
-- new index as well
placeNewInto :: ALens' World (IM.IntMap a)
plNewID :: ALens' World (IM.IntMap a)
-> a
-> GenWorld
-> (Int,GenWorld)
placeNewInto l x w = (i,w & gWorld . l #%~ IM.insert i x)
plNewID l x w = (i,w & gWorld . l #%~ IM.insert i x)
where
i = IM.newKey $ _gWorld w ^# l
@@ -176,8 +176,8 @@ mvPP p rot pp = pp {_ppPos = p,_ppRot = rot}
mvCr :: Point2 -> Float -> Creature -> Creature
mvCr p rot cr = cr {_crPos = p,_crOldPos = p,_crDir = rot}
placeMachine :: Color -> [Point2] -> Machine -> Point2 -> Float -> GenWorld -> (Int,GenWorld)
placeMachine color wallpoly mc p rot gw = (mcid
plMachine :: Color -> [Point2] -> Machine -> Point2 -> Float -> GenWorld -> (Int,GenWorld)
plMachine color wallpoly mc p rot gw = (mcid
, gw & gWorld . machines %~ addMc
& gWorld . walls %~ placeMachineWalls color wallpoly mcid wlid
)
src/Dodge/Placement/PlaceSpot/TriggerDoor.hs
+21 -28
View File
@@ -1,7 +1,7 @@
--{-# LANGUAGE BangPatterns #-}
module Dodge.Placement.PlaceSpot.TriggerDoor
( placeDoor
, placeSlideDoor
( plDoor
, plSlideDoor
) where
import Dodge.Data
import Dodge.Default.Wall
@@ -17,14 +17,13 @@ import Data.List
import Control.Lens
--import Data.Graph.Inductive hiding ((&))
import qualified Data.IntSet as IS
placeDoor
:: Color
plDoor :: Color
-> (World -> Bool) -- ^ Opening condition
-> [(Point2,Point2)] -- ^ Door positions, closed to open.
-- Bumped out up and down by 9, not widened
-> GenWorld
-> (Int,GenWorld)
placeDoor col cond pss gw = (drid, gw & gWorld .~ (addWalls w & doors %~ addDoor))
plDoor col cond pss gw = (drid, gw & gWorld .~ (addWalls w & doors %~ addDoor))
where
w = _gWorld gw
drid = IM.newKey $ _doors w
@@ -38,27 +37,29 @@ placeDoor col cond pss gw = (drid, gw & gWorld .~ (addWalls w & doors %~ addDoo
nsteps = length pss - 1
wlids = take 4 [IM.newKey $ _walls w ..]
wlps' = uncurry (rectanglePairs 9) $ head pss
addWalls w' = foldl' addWall w' $ zip wlids wlps'
addWall w' (wlid, wlps) = w' & walls %~ IM.insert wlid defaultWall
{ _wlLine = wlps
, _wlID = wlid
, _wlColor = col
, _wlSeen = False
, _wlOpacity = Opaque
, _wlPathable = False
}
addWalls w' = foldl' (addDoorWall col False) w' $ zip wlids wlps'
addDoorWall :: Color -> Bool -> World -> (Int,(Point2,Point2)) -> World
addDoorWall col pathableStatus w (wlid,wlps) = w & walls %~ IM.insert wlid defaultWall
{ _wlLine = wlps
, _wlID = wlid
, _wlColor = col
, _wlSeen = False
, _wlOpacity = Opaque
, _wlPathable = pathableStatus
}
-- TODO use vector instead of list, perhaps also memoisation of rectanglePairs
-- perhaps also remove use of DoorInt in favour of DoorOpen/DoorClosed
doorMechanismStepwise :: Int -> Int -> [Int] -> [(Point2,Point2)] -> Door -> World -> World
doorMechanismStepwise nsteps drid wlids pss dr w
| toOpen = case _drStatus dr of
DoorInt x | x == nsteps -> w
DoorInt x -> setWalls (x+1)
_ -> w
DoorInt x -> setWalls (x+1)
_ -> w
| otherwise = case _drStatus dr of
DoorInt 0 -> w
DoorInt x -> setWalls (x-1)
_ -> w
_ -> w
where
playSound = soundContinue (WallSound drid) (fst $ head pss) slideDoorS (Just 1)
toOpen = _drTrigger dr w
@@ -88,9 +89,9 @@ doorMechanism drid speed wlidOpCps dr w
doClose w' (wlid,_ ,clp) = moveWallIDToward wlid speed clp w'
-- TODO cut pathing if not pathable, reset when opened
placeSlideDoor :: Bool -> Color -> (World -> Bool) -> Point2 -> Point2 -> Float -> GenWorld
plSlideDoor :: Bool -> Color -> (World -> Bool) -> Point2 -> Point2 -> Float -> GenWorld
-> (Int, GenWorld)
placeSlideDoor isPathable col cond a b speed gw = (drid, gw & gWorld .~ (addWalls w & doors %~ addDoor))
plSlideDoor isPathable col cond a b speed gw = (drid, gw & gWorld .~ (addWalls w & doors %~ addDoor))
where
w = _gWorld gw
drid = IM.newKey $ _doors w
@@ -101,15 +102,7 @@ placeSlideDoor isPathable col cond a b speed gw = (drid, gw & gWorld .~ (addWall
, _drTrigger = cond
, _drMech = doorMechanism drid speed (zip3 wlids shiftedPairs pairs)
}
addWalls w' = foldl' addWall w' $ zip wlids pairs
addWall w' (wlid, wlps) = w' & walls %~ IM.insert wlid defaultWall
{ _wlLine = wlps
, _wlID = wlid
, _wlColor = col
, _wlSeen = False
, _wlOpacity = Opaque
, _wlPathable = isPathable
}
addWalls w' = foldl' (addDoorWall col isPathable) w' $ zip wlids pairs
pairs = rectanglePairs 9 a b
shiftedPairs = map (bimap shiftLeft shiftLeft) pairs
shiftLeft = (+.+ (a -.- b +.+ normalizeV (b -.- a)))