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

Various improvements, metal debris

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