From 8d266a67708f08d5225f6b740de11086a27b049d Mon Sep 17 00:00:00 2001 From: justin Date: Thu, 23 Jun 2022 18:53:26 +0100 Subject: [PATCH] Various improvements, metal debris --- src/Dodge/Block.hs | 2 +- src/Dodge/Block/Debris.hs | 84 ++++++++++++++------ src/Dodge/Data.hs | 2 +- src/Dodge/Default/Door.hs | 24 +++++- src/Dodge/Default/Wall.hs | 5 ++ src/Dodge/Item/Weapon/Shatter.hs | 5 +- src/Dodge/Item/Weapon/TriggerType.hs | 3 +- src/Dodge/Placement/Instance/Door.hs | 36 ++++----- src/Dodge/Placement/PlaceSpot.hs | 15 ++-- src/Dodge/Placement/PlaceSpot/Block.hs | 2 +- src/Dodge/Placement/PlaceSpot/TriggerDoor.hs | 20 ++--- src/Dodge/Prop/Moving.hs | 1 + src/Dodge/Room/Airlock.hs | 8 +- src/Dodge/Room/Door.hs | 3 +- src/Dodge/Room/LongDoor.hs | 8 +- src/Dodge/Room/Procedural.hs | 5 +- src/Dodge/Wall/Zone.hs | 2 +- src/Geometry.hs | 4 +- 18 files changed, 147 insertions(+), 82 deletions(-) diff --git a/src/Dodge/Block.hs b/src/Dodge/Block.hs index 7baf21e5e..bd628ea61 100644 --- a/src/Dodge/Block.hs +++ b/src/Dodge/Block.hs @@ -32,7 +32,7 @@ unshadowBlock wlid w = case w ^? walls . ix wlid of & walls . ix wlid . wlDraw .~ True & wallsZone . znObjects . ix x . ix y . ix wlid . wlDraw .~ True where - (x,y) = zoneOfPoint $ uncurry pHalf (_wlLine wl) + (x,y) = zoneOfPoint $ uncurry midPoint (_wlLine wl) Nothing -> w checkBlockHP :: Block -> World -> World diff --git a/src/Dodge/Block/Debris.hs b/src/Dodge/Block/Debris.hs index 25943b7c5..40a18d3b1 100644 --- a/src/Dodge/Block/Debris.hs +++ b/src/Dodge/Block/Debris.hs @@ -16,48 +16,74 @@ import qualified Quaternion as Q import qualified Data.IntSet as IS import Data.Maybe -makeBlockDebris :: Block -> World -> World -makeBlockDebris bl w = w & makeDebris mt (_blPos bl) + +makeDoorDebris :: Door -> World -> World +makeDoorDebris dr w = w & makeDebris mt col p where - mt = fromMaybe Stone $ do + p = uncurry midPoint (_drPos dr) + (mt,col) = fromMaybe (Stone,greyN 0.5) $ do + wlids <- w ^? doors . ix (_drID dr) . drWallIDs + (wlid,_) <- IS.minView wlids + wl <- w ^? walls . ix wlid + return (_wlMaterial wl,_wlColor wl) + +makeBlockDebris :: Block -> World -> World +makeBlockDebris bl w = w & makeDebris mt col (_blPos bl) + where + (mt,col) = fromMaybe (Stone,greyN 0.5) $ do wlids <- w ^? blocks . ix (_blID bl) . blWallIDs (wlid,_) <- IS.minView wlids - w ^? walls . ix wlid . wlMaterial + wl <- w ^? walls . ix wlid + return (_wlMaterial wl,_wlColor wl) -makeDebris :: Material -> Point2 -> World -> World +makeDebris :: Material -> Color -> Point2 -> World -> World makeDebris = makeDebrisDirected 1 2 (2*pi) 0 -makeDebrisDirected :: Float -> Float - -> Float -> Float -> Material -> Point2 -> World -> World -makeDebrisDirected mindist maxdist arcrad dir bm p w = w +makeDebrisDirected :: Float + -> Float + -> Float + -> Float + -> Material + -> Color + -> Point2 + -> World -> World +makeDebrisDirected mindist maxdist arcrad dir bm col p w = w & flip (foldr (plNew props pjID)) thedebris & randGen .~ newg & originsIDsAt [MaterialSound bm i | i <- [0,1,2]] (destroyMatS bm) p where - someDebris = case bm of - Stone -> stoneDebris - Glass -> glassDebris - Crystal -> crystalDebris - Dirt -> dirtDebris - Wood -> stoneDebris - Metal -> stoneDebris - (thedebris,newg) = runState (mapM f [35,55..95]) $ _randGen w + (thedebris,newg) = mapM f [35,55..95] & runState $ _randGen w f h = do v <- rotateV (dir - arcrad/2) <$> randInArcStrip mindist maxdist arcrad q <- Q.vToQuat (V3 0 0 1) <$> randOnUnitSphere - return $ someDebris + spinspeed <- randomR (-0.2,-0.1) & state + basedebris <- baseDebris bm + return $ basedebris + & pjColor .~ col & prPos .~ p & pjVel .~ v - & pjQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) (-0.1) + & pjQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) spinspeed & pjQuat .~ q & pjVelZ .~ 0 & pjPosZ .~ h +baseDebris :: Material -> State StdGen Prop +baseDebris mt = case mt of + Stone -> return stoneDebris + Glass -> return glassDebris + Crystal -> return crystalDebris + Dirt -> return dirtDebris + Wood -> return stoneDebris + Metal -> do + sh <- jaggedShape + return $ metalDebris + & prDraw .~ (`drawMovingShape` sh) + stoneDebris :: Prop stoneDebris = PropZ {_prPos = 0 ,_pjStartPos = 0 ,_pjVel = 0 - ,_prDraw = \pr -> drawMovingShape pr (debrisShape 4 pr) + ,_prDraw = \pr -> drawMovingShape pr (cubeShape 4) ,_pjID = 0 ,_pjUpdate = fallSmallBounceDamage ,_pjPosZ = 10 @@ -74,21 +100,31 @@ dirtDebris = stoneDebris dirtColor :: Color dirtColor = V4 (150/256) ( 75/256) 0 ( 250/256) +metalDebris :: Prop +metalDebris = stoneDebris + & prDraw .~ (\pr -> drawMovingShape pr (shardShape 4)) + & pjUpdate .~ fallSmallBounce + glassDebris :: Prop glassDebris = stoneDebris - & prDraw .~ (\pr -> drawMovingShape pr (shardShape 4 pr)) + & prDraw .~ (\pr -> drawMovingShape pr (shardShape 4)) & pjUpdate .~ fallSmallBounce & pjColor .~ withAlpha 0.5 cyan crystalDebris :: Prop crystalDebris = glassDebris & pjColor .~ withAlpha 0.5 aquamarine -shardShape :: Float -> Prop -> Shape -shardShape size pr = colorSH (_pjColor pr) . translateSHz (-size) $ upperPrismPoly size +shardShape :: Float -> Shape +shardShape size = translateSHz (-size) $ upperPrismPoly size [V2 size 0 ,V2 (-size) 1 ,V2 (-size) (-1) ] -debrisShape :: Float -> Prop -> Shape -debrisShape size pr = colorSH (_pjColor pr) . translateSHz (-size) $ upperPrismPoly (2*size) $ square size +jaggedShape :: State StdGen Shape +jaggedShape = do + s <- randomR (4,10) & state + return $ shardShape s + +cubeShape :: Float -> Shape +cubeShape size = translateSHz (-size) $ upperPrismPoly (2*size) $ square size diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index 8633216f8..6269470f3 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -1397,7 +1397,7 @@ data PSType = PutCrit {_unPutCrit :: Creature} | PutLineBlock {_putWall :: Wall , _putWidth :: Float , _putDepth :: Float, _putStartPoint :: Point2, _putEndPoint :: Point2} | PutWall { _pwPoly :: [Point2] , _pwWall :: Wall } - | PutSlideDr Bool Color Door Float Point2 Point2 + | PutSlideDr Door Wall Float Point2 Point2 -- | PutSlideDr Bool Color (World -> Bool) Float Point2 Point2 Float | PutDoor Color (World -> Bool) [(Point2,Point2)] | RandPS (State StdGen PSType) diff --git a/src/Dodge/Default/Door.hs b/src/Dodge/Default/Door.hs index 7b77d41e2..1d6bc4301 100644 --- a/src/Dodge/Default/Door.hs +++ b/src/Dodge/Default/Door.hs @@ -1,5 +1,25 @@ -module Dodge.Default.Door where +module Dodge.Default.Door + ( module Dodge.Default.Door + , module Dodge.Default.Wall + ) where import Dodge.Data +import Dodge.Default.Wall +import Dodge.Block.Debris +import Color + +import Control.Lens + +switchWallCol :: Color -> Wall +switchWallCol col = defaultSwitchWall & wlColor .~ col + +defaultAutoWall :: Wall +defaultAutoWall = defaultDoorWall' + & wlColor .~ dim yellow + & wlPathable .~ True +defaultSwitchWall :: Wall +defaultSwitchWall = defaultDoorWall' + & wlColor .~ red + & wlPathable .~ False defaultDoor :: Door defaultDoor = Door @@ -12,7 +32,7 @@ defaultDoor = Door , _drOpenPos = (0,0) , _drClosePos = (0,0) , _drHP = 10000 - , _drDeath = const id + , _drDeath = makeDoorDebris , _drSpeed = 1 , _drPushedBy = PushesItself , _drPushes = Nothing diff --git a/src/Dodge/Default/Wall.hs b/src/Dodge/Default/Wall.hs index e062a7967..e5d4262d2 100644 --- a/src/Dodge/Default/Wall.hs +++ b/src/Dodge/Default/Wall.hs @@ -23,6 +23,11 @@ defaultWall = Wall , _wlHeight = 100 , _wlMaterial = Stone } +defaultDoorWall' :: Wall +defaultDoorWall' = defaultWall + { _wlPathable = True + , _wlMaterial = Metal + } {- Indestructible see-through wall. -} defaultCrystalWall :: Wall defaultCrystalWall = defaultWall diff --git a/src/Dodge/Item/Weapon/Shatter.hs b/src/Dodge/Item/Weapon/Shatter.hs index 6c67b8d4a..139001066 100644 --- a/src/Dodge/Item/Weapon/Shatter.hs +++ b/src/Dodge/Item/Weapon/Shatter.hs @@ -60,6 +60,7 @@ shootShatter it cr w = maybe w (uncurry $ shatterWall w sp ep) $ collidePointWal shatterWall :: World -> Point2 -> Point2 -> Point2 -> Wall -> World shatterWall w sp ep p wl = w - & makeDebris (_wlMaterial wl) p - & makeDebrisDirected 1 2 (pi/2) (argV $ vNormal $ uncurry (-.-) $ _wlLine wl) (_wlMaterial wl) p + & makeDebris (_wlMaterial wl) (_wlColor wl) p + & makeDebrisDirected 1 2 (pi/2) (argV $ vNormal $ uncurry (-.-) $ _wlLine wl) (_wlMaterial wl) + (_wlColor wl) p & damageWall (Damage SHATTERING 1000 sp p ep NoDamageEffect) wl diff --git a/src/Dodge/Item/Weapon/TriggerType.hs b/src/Dodge/Item/Weapon/TriggerType.hs index 4a9686c9f..6c680a61c 100644 --- a/src/Dodge/Item/Weapon/TriggerType.hs +++ b/src/Dodge/Item/Weapon/TriggerType.hs @@ -185,8 +185,7 @@ withWarmUp :: SoundID -- ^ warm up sound id -> ChainEffect withWarmUp soundID f item cr w - | crWeaponReady cr = w - | curWarmUp < maxWarmUp = w + | curWarmUp < maxWarmUp && crWeaponReady cr = w & pointerToItem . itUse . useDelay . warmTime +~ 2 & soundContinue (CrWeaponSound cid 0) (_crPos cr) soundID (Just 2) | otherwise = w diff --git a/src/Dodge/Placement/Instance/Door.hs b/src/Dodge/Placement/Instance/Door.hs index ef5baebbd..904307474 100644 --- a/src/Dodge/Placement/Instance/Door.hs +++ b/src/Dodge/Placement/Instance/Door.hs @@ -6,7 +6,6 @@ module Dodge.Placement.Instance.Door ) where import Dodge.Data import Dodge.Default.Door ---import Dodge.Base import Color import Geometry import Dodge.LevelGen.Data @@ -16,47 +15,48 @@ import Dodge.LevelGen.Switch import Control.Lens import qualified Data.IntMap.Strict as IM -putDoubleDoor :: Bool -> Color -> (World -> Bool) -> Point2 -> Point2 -> Float -> Placement -putDoubleDoor pathing col cond a b speed - = putDoubleDoorThen pathing col cond 1 a b speed (const $ const Nothing) +putDoubleDoor :: Wall -> (World -> Bool) -> Point2 -> Point2 -> Float -> Placement +putDoubleDoor wl cond a b speed + = putDoubleDoorThen wl cond 1 a b speed (const $ const Nothing) -putDoubleDoorThen :: Bool -> Color -> (World -> Bool) +putDoubleDoorThen :: Wall -> (World -> Bool) -> Float -> Point2 -> Point2 -> Float -> (Placement -> Placement -> Maybe Placement) -> Placement -putDoubleDoorThen pathing col cond soff a b speed cont - = doorBetween pathing col cond soff a half speed - $ \pl1 -> Just $ doorBetween pathing col cond soff b half speed +putDoubleDoorThen wl cond soff a b speed cont + = doorBetween wl cond soff a half speed + $ \pl1 -> Just $ doorBetween wl cond soff b half speed $ \pl2 -> cont pl1 pl2 where half = 0.5 *.* (a +.+ b) -doorBetween :: Bool -> Color -> (World -> Bool) -> Float -> Point2 -> Point2 -> Float -> +doorBetween :: Wall -> (World -> Bool) -> Float -> Point2 -> Point2 -> Float -> (Placement -> Maybe Placement) -> Placement -doorBetween pathing col cond soff pa pb speed g = case divideLine 40 pa pb of - [x,y] -> ptCont (PutSlideDr pathing col adoor soff x y) g - (x:y:zs) -> divideDoorPane Nothing pathing col cond (soff - dist y pb) speed (zip (x:y:zs) (y:zs)) g +doorBetween wl cond soff pa pb speed g = case divideLine 40 pa pb of + [x,y] -> ptCont (PutSlideDr adoor wl soff x y) g + (x:y:zs) -> divideDoorPane Nothing wl cond (soff - dist y pb) speed (zip (x:y:zs) (y:zs)) g _ -> undefined where adoor = defaultDoor & drTrigger .~ cond & drSpeed .~ speed -divideDoorPane :: Maybe Int -> Bool -> Color -> (World -> Bool) -> Float -> Float +divideDoorPane :: Maybe Int -> Wall -> (World -> Bool) -> Float -> Float -> [(Point2,Point2)] -> (Placement -> Maybe Placement) -> Placement -divideDoorPane mid pathing col cond soff speed ppairs g = case ppairs of +divideDoorPane mid wl cond soff speed ppairs g = case ppairs of [p] -> ptCont (adoor p) g - (p:ps) -> ptCont (adoor p) $ \pl -> Just $ divideDoorPane (_plMID pl) pathing col cond soff speed ps g + (p:ps) -> ptCont (adoor p) $ \pl -> Just $ divideDoorPane (_plMID pl) wl cond soff speed ps g _ -> undefined where - adoor (x,y) = PutSlideDr pathing col thedoor soff x y + adoor (x,y) = PutSlideDr thedoor wl soff x y thedoor = defaultDoor & drSpeed .~ speed & drTrigger .~ cond & drPushedBy .~ maybe PushesItself PushedBy mid putAutoDoor :: Point2 -> Point2 -> Placement putAutoDoor a b = PlacementUsingPos (addZ 0 a) $ \az -> PlacementUsingPos (addZ 0 b) - $ \bz -> putDoubleDoor True (dim yellow) (cond az bz) a b 3 + $ \bz -> putDoubleDoor defaultAutoWall + (cond az bz) a b 3 where --cond az bz = any (crNearSeg 40 (stripZ az) (stripZ bz)) . IM.filter isAnimate . _creatures cond az bz = any (crNearPoint 40 (0.5 *.* (stripZ az +.+ stripZ bz))) @@ -67,7 +67,7 @@ switchDoor btpos btrot dra drb col = pContID (PS btpos btrot) (PutButton $ makeS $ \btid -> jsps0J (doorbetween btid dra drc) $ sps0 (doorbetween btid drb drc) where - doorbetween btid a b = PutSlideDr False col thedoor 1 a b + doorbetween btid a b = PutSlideDr thedoor (switchWallCol col) 1 a b where thedoor = defaultDoor & drTrigger .~ cond btid diff --git a/src/Dodge/Placement/PlaceSpot.hs b/src/Dodge/Placement/PlaceSpot.hs index 59c38aba0..d0c74f7e5 100644 --- a/src/Dodge/Placement/PlaceSpot.hs +++ b/src/Dodge/Placement/PlaceSpot.hs @@ -23,6 +23,7 @@ import Shape import qualified IntMapHelp as IM import Color +import Data.Foldable import Data.Maybe import System.Random import Control.Monad.State @@ -101,8 +102,8 @@ placeSpotID ps pt w = case pt of RandPS rgn -> evaluateRandPS rgn ps w PutDoor col f pss -> plDoor col f (map (bimap doShift doShift) pss) w PutCoord cp -> plNewID coordinates (doShift cp) w - PutSlideDr pth col dr off a b - -> plSlideDoor pth col dr off (doShift a) (doShift b) w + PutSlideDr wl dr off a b + -> plSlideDoor wl dr off (doShift a) (doShift b) w PutBlock bl wl ps' -> placeBlock (map doShift ps') (bl & blPos %~ doShift & blDir .~ rot) wl w PutLineBlock wl wdth dpth a b -> placeLineBlock wl wdth dpth (doShift a) (doShift b) w @@ -129,18 +130,18 @@ evaluateRandPS rgen ps w = placeSpotID ps evaluatedType (set randGen g w) (evaluatedType, g) = runState rgen (_randGen w) placeWallPoly :: [Point2] -> Wall -> World -> World -placeWallPoly ps wl = rmCrossPaths . over walls (addWalls ps wl) +placeWallPoly ps wl = rmCrossPaths . over walls (placeWalls ps wl) where rmCrossPaths w = foldr (uncurry removePathsCrossing) w $ loopPairs ps -addWalls :: [Point2] -> Wall -> IM.IntMap Wall -> IM.IntMap Wall -addWalls qs wl wls = foldr (addPane wl) wls pairs +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) -addPane :: Wall -> (Point2,Point2) -> IM.IntMap Wall -> IM.IntMap Wall -addPane wl l wls = IM.insert wlid (wl { _wlLine = l, _wlID = wlid }) wls +addPane :: Wall -> IM.IntMap Wall -> (Point2,Point2) -> IM.IntMap Wall +addPane wl wls l = IM.insert wlid (wl { _wlLine = l, _wlID = wlid }) wls where wlid = IM.newKey wls diff --git a/src/Dodge/Placement/PlaceSpot/Block.hs b/src/Dodge/Placement/PlaceSpot/Block.hs index d7a8ce480..9d24fa2a4 100644 --- a/src/Dodge/Placement/PlaceSpot/Block.hs +++ b/src/Dodge/Placement/PlaceSpot/Block.hs @@ -47,7 +47,7 @@ addBlock (p:ps) wl bl w = w = insertIMInZone x y wlid wl' | otherwise = flip (foldl' $ flip (\(a,b) -> insertIMInZone a b wlid wl')) ips where - (x,y) = zoneOfPoint $ uncurry pHalf (_wlLine wl) + (x,y) = zoneOfPoint $ uncurry midPoint (_wlLine wl) wlid = _wlID wl ips = map zoneOfPoint $ uncurry (divideLine (2*zoneSize)) (_wlLine wl) addBlock _ _ _ _ = error "Trying to add a block with incomplete polygon" diff --git a/src/Dodge/Placement/PlaceSpot/TriggerDoor.hs b/src/Dodge/Placement/PlaceSpot/TriggerDoor.hs index 723b81483..83403510c 100644 --- a/src/Dodge/Placement/PlaceSpot/TriggerDoor.hs +++ b/src/Dodge/Placement/PlaceSpot/TriggerDoor.hs @@ -5,7 +5,6 @@ module Dodge.Placement.PlaceSpot.TriggerDoor ) where import Dodge.Data import Dodge.Base -import Dodge.Default.Wall import Dodge.Default.Door import Dodge.Wall.Move import Dodge.LevelGen.DoorPane @@ -42,14 +41,12 @@ plDoor col cond pss gw = (drid, addWalls gw & doors %~ addDoor) nsteps = length pss - 1 wlids = take 4 [IM.newKey $ _walls gw ..] wlps' = uncurry (rectanglePairs 9) $ head pss - addWalls w' = foldl' (addDoorWall drid col False) w' $ zip wlids wlps' + addWalls w' = foldl' (addDoorWall drid $ switchWallCol col) w' $ zip wlids wlps' -addDoorWall :: Int -> Color -> Bool -> World -> (Int,(Point2,Point2)) -> World -addDoorWall drid col pathableStatus w (wlid,wlps) = w & walls %~ IM.insert wlid defaultWall +addDoorWall :: Int -> Wall -> World -> (Int,(Point2,Point2)) -> World +addDoorWall drid wl w (wlid,wlps) = w & walls %~ IM.insert wlid wl { _wlLine = wlps , _wlID = wlid - , _wlColor = col - , _wlPathable = pathableStatus , _wlStructure = DoorPart drid } -- TODO use vector instead of list, perhaps also memoisation of rectanglePairs @@ -80,7 +77,7 @@ doorMechanismStepwise nsteps drid wlids pss dr w doorMechanism :: Door -> World -> World doorMechanism dr w = case mvDir of Just d -> w - & flip (IS.foldr (`translateWallID` d)) (_drWallIDs dr) + & flip (IS.foldl' (flip (`translateWallID` d))) (_drWallIDs dr) & moveUpdate & doors . ix drid . drPos . each %~ (+.+ d) Nothing -> w @@ -105,15 +102,14 @@ doorMechanism dr w = case mvDir of -- TODO cut pathing if not pathable, reset when opened plSlideDoor - :: Bool - -> Color - -> Door + :: Door + -> Wall -> Float -> Point2 -> Point2 -> World -> (Int, World) -plSlideDoor isPathable col dr shiftOffset a b gw +plSlideDoor dr wl shiftOffset a b gw = (drid, addDoorWalls gw & doors %~ addDoor) where drid = IM.newKey $ _doors gw @@ -126,7 +122,7 @@ plSlideDoor isPathable col dr shiftOffset a b gw , _drOpenPos = (shiftLeft a,shiftLeft b) , _drClosePos = (a,b) } - addDoorWalls w' = foldl' (addDoorWall drid col isPathable) w' $ zip wlids pairs + addDoorWalls w' = foldl' (addDoorWall drid wl) w' $ zip wlids pairs pairs = rectanglePairs 9 a b shiftLeft = (+.+ (a -.- b +.+ shiftOffset *.* normalizeV (b -.- a))) wlids = take 4 [IM.newKey $ _walls gw ..] diff --git a/src/Dodge/Prop/Moving.hs b/src/Dodge/Prop/Moving.hs index bef7e9433..44fd68d5e 100644 --- a/src/Dodge/Prop/Moving.hs +++ b/src/Dodge/Prop/Moving.hs @@ -67,3 +67,4 @@ drawMovingShape pr = noPic . translateSHz (_pjPosZ pr) . uncurryV translateSHf (_prPos pr) . overPosSH (Q.rotate (_pjQuat pr)) + . colorSH (_pjColor pr) diff --git a/src/Dodge/Room/Airlock.hs b/src/Dodge/Room/Airlock.hs index d45b4141b..24f346cf5 100644 --- a/src/Dodge/Room/Airlock.hs +++ b/src/Dodge/Room/Airlock.hs @@ -5,7 +5,7 @@ import Dodge.Placement.Instance import Dodge.Room.Foreground import Dodge.RoomLink import Dodge.Default.Room -import Dodge.Default.Wall +import Dodge.Default.Door import Dodge.Data import Dodge.LevelGen.Data import Dodge.LevelGen.Switch @@ -13,6 +13,7 @@ import RandomHelp import Geometry import Picture +--import Control.Lens import qualified Data.IntMap.Strict as IM {- | A passage with a switch that opens forward access while closing backwards access. -} airlock :: RandomGen g => State g Room @@ -26,8 +27,8 @@ airlock0 = defaultRoom , _rmPath = [(V2 20 95,V2 20 45) ,(V2 20 45,V2 20 5) ] , _rmPmnts = [pContID (PS (V2 (-35) 50) (negate $ pi/2)) (PutButton $ makeSwitch col red id id) - $ \btid -> Just $ putDoubleDoorThen False col (not . cond' btid) 1 (V2 0 20) (V2 40 20) 2 - $ \_ _ -> Just $ putDoubleDoor False col (cond' btid) (V2 0 80) (V2 40 80) 2 + $ \btid -> Just $ putDoubleDoorThen thewall (not . cond' btid) 1 (V2 0 20) (V2 40 20) 2 + $ \_ _ -> Just $ putDoubleDoor thewall (cond' btid) (V2 0 80) (V2 40 80) 2 , invisibleWall $ rectNSWE 60 40 (-40) (-30) ,spanLightI (V2 (-2) 30) (V2 (-2) 70) ,sps0 $ PutShape $ thinHighBar 75 (V2 40 50) (V2 (-1) 50) @@ -35,6 +36,7 @@ airlock0 = defaultRoom , _rmBound = [rectNSWE 75 15 0 40,switchcut] } where + thewall = switchWallCol col switchcut = rectNSWE 65 35 (-40) 20 lnks = [(V2 20 95,0) ,(V2 20 5,pi) diff --git a/src/Dodge/Room/Door.hs b/src/Dodge/Room/Door.hs index ca2e15383..7e6732646 100644 --- a/src/Dodge/Room/Door.hs +++ b/src/Dodge/Room/Door.hs @@ -5,6 +5,7 @@ import Geometry import Dodge.RoomLink import Dodge.Data import Dodge.Default.Room +import Dodge.Default.Door import Dodge.Placement.Instance import Color @@ -39,6 +40,6 @@ triggerDoorRoom inplid = defaultRoom -- note no bounds } where - f (pmnt:_) = putDoubleDoor False red (cond pmnt) (V2 0 20) (V2 40 20) 2 + f (pmnt:_) = putDoubleDoor (switchWallCol red) (cond pmnt) (V2 0 20) (V2 40 20) 2 f _ = error "tried to put a door using an empty placement list" cond pmnt w = w & _triggers w IM.! fromJust (_plMID pmnt) diff --git a/src/Dodge/Room/LongDoor.hs b/src/Dodge/Room/LongDoor.hs index 3d7081c0e..5420ec082 100644 --- a/src/Dodge/Room/LongDoor.hs +++ b/src/Dodge/Room/LongDoor.hs @@ -46,8 +46,8 @@ twinSlowDoorRoom w h x = defaultRoom , _rmPath = [] , _rmPmnts = [ pContID (PS (V2 0 (h-5)) pi) ( PutButton $ makeButton col id) - $ \btid -> jsps0J (PutSlideDr False col (thedoor btid) 1 (V2 x 1) (V2 x h)) - $ ps0 (PutSlideDr False col (thedoor btid) 1 (V2 (-x) 1) (V2 (-x) h)) + $ \btid -> jsps0J (PutSlideDr (thedoor btid) thewall 1 (V2 x 1) (V2 x h)) + $ ps0 (PutSlideDr (thedoor btid) thewall 1 (V2 (-x) 1) (V2 (-x) h)) $ \did -> jps0' (PutLS (lsColPos (V3 0.75 0 0) (V3 0 (h-1) lampHeight))) $ \lspl -> jsps0 $ PutProp $ addColorChange (fromJust $ _plMID lspl) did $ lampCoverWhen (drmoving did) (V2 0 (h-1)) lampHeight ] @@ -56,6 +56,7 @@ twinSlowDoorRoom w h x = defaultRoom , _rmViewpoints = [V2 0 h] } where + thewall = switchWallCol red wlSpeed = 0.5 addColorChange lsid drid = over pjUpdate $ dbArgChain $ const f where @@ -114,9 +115,10 @@ addButtonSlowDoor x h rm = do [MountedLS (fromJust $ _plMID plls), MountedProp (fromJust $ _plMID plpr)] -- TODO make the height of this light source and of other mounted lights -- be taken from a single consistent source + thewall = switchWallCol red butDoor = putLitButOnPos col (rprBool (isUnusedLnkType InLink)) - $ \btplmnt -> Just $ putDoubleDoorThen False col (cond' $ fromJust $ _plMID btplmnt) + $ \btplmnt -> Just $ putDoubleDoorThen thewall (cond' $ fromJust $ _plMID btplmnt) 30 (V2 0 h) (V2 x h) 2 $ \dr1 dr2 -> amountedlight dr1 50 diff --git a/src/Dodge/Room/Procedural.hs b/src/Dodge/Room/Procedural.hs index a4ae3c7e7..428c88431 100644 --- a/src/Dodge/Room/Procedural.hs +++ b/src/Dodge/Room/Procedural.hs @@ -267,9 +267,10 @@ centerVaultRoom w h d = return $ defaultRoom col = dim $ dim $ bright red theDoor = [ pContID (PS (V2 35 (d+4)) 0) (PutButton $ makeSwitch col red id id) - $ \btid -> jspsJ (V2 0 (d-10)) 0 (PutSlideDr False col (thedoor btid) 1 (V2 (-21) 0) (V2 0 0)) - $ sPS (V2 0 (d-10)) 0 (PutSlideDr False col (thedoor btid) 1 (V2 21 0) (V2 0 0)) + $ \btid -> jspsJ (V2 0 (d-10)) 0 (PutSlideDr (thedoor btid) thewall 1 (V2 (-21) 0) (V2 0 0)) + $ sPS (V2 0 (d-10)) 0 (PutSlideDr (thedoor btid) thewall 1 (V2 21 0) (V2 0 0)) ] + thewall = switchWallCol col thedoor btid = defaultDoor & drTrigger .~ (\w' -> _btState (_buttons w' IM.! btid) == BtOn) & drSpeed .~ 2 diff --git a/src/Dodge/Wall/Zone.hs b/src/Dodge/Wall/Zone.hs index a292f3a31..3ecf63b29 100644 --- a/src/Dodge/Wall/Zone.hs +++ b/src/Dodge/Wall/Zone.hs @@ -10,7 +10,7 @@ import Data.Foldable zoneOfWall :: Wall -> [(Int,Int)] zoneOfWall wl - | uncurry dist wlline <= 2*zoneSize = [zoneOfPoint $ uncurry pHalf wlline ] + | uncurry dist wlline <= 2*zoneSize = [zoneOfPoint $ uncurry midPoint wlline ] | otherwise = map zoneOfPoint $ uncurry (divideLine zoneSize) wlline where wlline = _wlLine wl diff --git a/src/Geometry.hs b/src/Geometry.hs index 7c82dd40f..2e57cb672 100644 --- a/src/Geometry.hs +++ b/src/Geometry.hs @@ -68,8 +68,8 @@ errorClosestPointOnLineParam _ !x! y! z | otherwise = closestPointOnLineParam x y z -- | Return midpoint between two points. -pHalf :: Point2 -> Point2 -> Point2 -pHalf !a !b = 0.5 *.* (a +.+ b) +midPoint :: Point2 -> Point2 -> Point2 +midPoint !a !b = 0.5 *.* (a +.+ b) -- | Test whether a circle is on a segment by intersecting a new normal segment through the -- center of the circle with the segment itself. -- Returns False if the circle center is beyond the endpoints of the