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

Working implementation of light change when door opens

Browse Source
This commit is contained in:
justin
2021-09-29 01:34:54 +01:00
parent 6b937b115e
commit f3437adef7
12 changed files with 87 additions and 66 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Data.hs
+1
View File
@@ -175,6 +175,7 @@ data LightSource = LS
, _lsDir :: !Float
, _lsRad :: !Float
, _lsIntensity :: !Point3
, _lsPict :: LightSource -> Picture
}
data TempLightSource = TLS
{ _tlsPos :: !Point3
src/Dodge/Layout.hs
+1 -1
View File
@@ -43,7 +43,7 @@ generateLevelFromRoomList gr w
. setupWorldBounds
-- . initializeStaticWalls
-- . setupForegroundEdgeVerxs
. flip (foldr placeSpot') plmnts
. flip (foldr $ flip placeSpot') plmnts
-- . addRoomPolyDecorations rs
-- . addRoomLinkDecorations rs
$ w { _walls = wallsFromRooms rs
src/Dodge/LevelGen.hs
+37 -33
View File
@@ -20,14 +20,15 @@ import Dodge.LevelGen.Data
import Geometry
import Geometry.Vector3D
import Shape
import Picture
import qualified IntMapHelp as IM
import Control.Monad.State
import Control.Lens
placeSpot' :: ((Point2,Float) , Placement) -> World -> World
placeSpot' (shift, plmnt) = placeSpot $ shiftPSBy' shift (_placementSpot plmnt)
placeSpot' :: World -> ((Point2,Float) , Placement) -> World
placeSpot' w (shift, plmnt) =
let (i,w') = placeSpotID (shiftPSBy' shift (_placementSpot plmnt)) w
in maybe w' (curry (placeSpot' w') shift) (_idPlacement plmnt i)
shiftPSBy'
:: (Point2,Float)
@@ -37,25 +38,25 @@ shiftPSBy' (pos,rot) ps = ps
& psPos %~ shiftPointBy (pos,rot)
& psRot %~ (+ rot)
placeSpot :: PlacementSpot -> World -> World
placeSpot ps w = case _psType ps of
placeSpotID :: PlacementSpot -> World -> (Int, World)
placeSpotID ps w = case _psType ps of
PutProp prop -> placeProp prop p rot w
PutButton bt -> placeBt bt p rot w
PutFlIt itm -> placeFlIt itm p rot w
PutCrit cr -> placeCr cr p rot w
PutLS ls dec -> placeLS ls dec p' rot w
PutLS ls -> placeLS ls p' rot w
PutPressPlate pp -> placePressPlate pp p rot w
RandPS rgen -> placeSpot (set psType evaluatedType ps) (set randGen g w)
RandPS rgen -> placeSpotID (set psType evaluatedType ps) (set randGen g w)
where
(evaluatedType, g) = runState rgen (_randGen w)
PutDoor col f pss -> putDoor col f (map (mapBoth $ shiftPointBy (p,rot)) pss) w
where
mapBoth fn (x,y) = (fn x, fn y)
PutDoubleDoor col f a b speed
-> putDoubleDoor False col f (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) speed w
PutSingleDoor col f a b speed
-> putSingleDoor False col f (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) speed w
PutAutoDoor a b -> addAutoDoor (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
PutDoubleDoor col f a b speed
-> (,) 0 $ insertDoubleDoor False col f (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) speed w
PutAutoDoor a b -> (,) 0 $ addAutoDoor (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
PutBlock (hp:hps) col ps' -> putBlock (map (shiftPointBy (p,rot)) ps') hp col False hps w
PutBlock{} -> error "messed up block placement somehow"
PutBtDoor c bp f a b speed
@@ -63,13 +64,13 @@ placeSpot ps w = case _psType ps of
(shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) speed w
PutLineBlock wl width depth a b
-> putLineBlock wl width depth (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
PutWall { _pwPoly = ps', _pwWall = wl } -> rmCrossPaths $ over walls (addWalls (q:qs) wl) w
PutWall { _pwPoly = ps', _pwWall = wl } -> (0,rmCrossPaths $ over walls (addWalls (q:qs) wl) w)
where
(q:qs) = map (shiftPointBy (p,rot)) ps'
rmCrossPaths w' = foldr (uncurry removePathsCrossing) w' $ zip (q:qs) (qs++[q])
PutForeground sh -> w & foregroundShape %~ ((uncurryV translateSHf p . rotateSH rot) sh <>)
PutNothing -> w
PutID _ -> w
PutForeground sh -> (0,w & foregroundShape %~ ((uncurryV translateSHf p . rotateSH rot) sh <>))
PutNothing -> (0,w)
PutID i -> (i, w)
--_ -> w
where
p@(V2 px py) = _psPos ps
@@ -113,15 +114,15 @@ addPane wl (p0,p1) wls = IM.insert (IM.newKey wls) (wl
})
wls
-- TODO make rotation of props sensible
placeProp
:: Prop
-> Point2
-> Float -- ^ Rotation
-> World
-> World
placeProp pr p a = over props addProp
-> (Int, World)
placeProp pr p a w = (i, w & props %~ addProp)
where
i = IM.newKey $ _props w
addProp prs = IM.insert (IM.newKey prs) (over pjRot (+a) pr {_pjPos = p, _pjID = IM.newKey prs}) prs
placePropID
@@ -140,9 +141,10 @@ placeBt
-> Point2
-> Float -- ^ Rotation
-> World
-> World
placeBt bt p rot = over buttons addBT
-> (Int, World)
placeBt bt p rot w = (i , over buttons addBT w)
where
i = IM.newKey $ _buttons w
addBT bts = IM.insert (IM.newKey bts) (bt {_btPos = p, _btRot = rot, _btID = IM.newKey bts}) bts
{- Creates a floor item at a given point.
Assigns an id correctly. -}
@@ -151,25 +153,29 @@ placeFlIt
-> Point2 -- ^ Position
-> Float -- ^ Rotation
-> World
-> World
placeFlIt itm p rot = floorItems %~
\ fis -> IM.insert (IM.newKey fis)
-> (Int, World)
placeFlIt itm p rot w = (i, w & floorItems %~
\ fis -> IM.insert i
(FlIt
{ _flItPos = p
, _flItRot = rot
, _flItID = IM.newKey fis
, _flItID = i
, _flIt = itm
}
) fis
)
where
i = IM.newKey $ _floorItems w
placePressPlate
:: PressPlate
-> Point2
-> Float -- ^ Rotation
-> World
-> World
placePressPlate pp p rot = over pressPlates addPP
-> (Int, World)
placePressPlate pp p rot w = (i , over pressPlates addPP w)
where
i = IM.newKey $ _pressPlates w
addPP pps = IM.insert (IM.newKey pps) (pp {_ppPos = p,_ppRot = rot}) pps
placeUpdateCr :: Creature -> Point2 -> Float -> World -> (World, PSType)
@@ -178,23 +184,21 @@ placeUpdateCr scr p rot w = (w & creatures %~ IM.insert cid cr, PutCrit cr)
cid = IM.newKey (_creatures w)
cr = scr {_crPos = p,_crOldPos = p,_crDir = rot,_crID = cid}
placeCr :: Creature -> Point2 -> Float -> World -> World
placeCr crF p rot = over creatures addCr
placeCr :: Creature -> Point2 -> Float -> World -> (Int,World)
placeCr crF p rot w = (i, over creatures addCr w)
where
i = IM.newKey $ _creatures w
addCr crs = IM.insert
(IM.newKey crs)
(crF {_crPos = p,_crOldPos = p,_crDir = rot,_crID = IM.newKey crs})
crs
placeLS :: LightSource -> Picture -> Point3 -> Float -> World -> World
placeLS ls dec (V3 x y z) rot w = over lightSources addLS $ over decorations addDec w
placeLS :: LightSource -> Point3 -> Float -> World -> (Int,World)
placeLS ls (V3 x y z) rot w = (i, over lightSources addLS w)
where
i = IM.newKey $ _lightSources w
startPos = _lsPos ls
addLS lss = IM.insert
(IM.newKey lss)
(ls {_lsPos = V3 x y z +.+.+ startPos,_lsDir = rot,_lsID = IM.newKey lss})
lss
addDec decs = IM.insert
(IM.newKey decs)
(translate x y $ rotate (negate rot) dec)
decs
src/Dodge/LevelGen/AutoDoor.hs
+2 -3
View File
@@ -3,8 +3,7 @@
Creation of doors that open when creatures approach them.
-}
module Dodge.LevelGen.AutoDoor
( addAutoDoor
) where
where
import Dodge.Data
import Dodge.Base
import Dodge.Creature.Property
@@ -22,6 +21,6 @@ addAutoDoor
-> Point2 -- ^ Right point (though the two points should be symmetric)
-> World
-> World
addAutoDoor a b = putDoubleDoor True (dim yellow) cond a b 3
addAutoDoor a b = insertDoubleDoor True (dim yellow) cond a b 3
where
cond = any (crNearSeg 40 a b) . IM.filter isAnimate . _creatures
src/Dodge/LevelGen/Block.hs
+3 -2
View File
@@ -135,8 +135,9 @@ addBlock (p:ps) hp col isSeeThrough degradability w
ips = map zoneOfPoint $ uncurry (divideLine (2*zoneSize)) (_wlLine wl)
addBlock _ _ _ _ _ _ = error "Trying to add a block with incomplete polygon"
putBlock :: [Point2] -> Int -> Color -> Bool -> [Int] -> World -> World
putBlock (p:ps) i c b is w = foldr (uncurry removePathsCrossing) wWithBlock pairs
-- TODO add block list to world
putBlock :: [Point2] -> Int -> Color -> Bool -> [Int] -> World -> (Int,World)
putBlock (p:ps) i c b is w = (0, foldr (uncurry removePathsCrossing) wWithBlock pairs)
where
pairs = zip (p:ps) (ps ++ [p])
wWithBlock = addBlock (p:ps) i c b is w
src/Dodge/LevelGen/Data.hs
+2 -1
View File
@@ -27,7 +27,7 @@ import Control.Lens
import Control.Monad.State
import System.Random
data PSType = PutCrit {_unPutCrit :: Creature}
| PutLS LightSource Picture
| PutLS LightSource
| PutButton Button
| PutProp Prop
| PutFlIt Item
@@ -49,6 +49,7 @@ data PlacementSpot = PS
, _psRot :: Float
, _psType :: PSType
}
-- maybe there is a monadic implementation of this?
data Placement = Placement
{ _placementSpot :: PlacementSpot
, _idPlacement :: Int -> Maybe Placement
src/Dodge/LevelGen/LineBlock.hs
+4 -2
View File
@@ -19,8 +19,10 @@ putLineBlock
-> Point2 -- ^ Start point (symmetric)
-> Point2 -- ^ End point (symmetric)
-> World
-> World
putLineBlock basePane blockWidth depth a b w = removePathsCrossing a b $ foldr insertBlock w listBlocks
-> (Int, World)
putLineBlock basePane blockWidth depth a b w
= (,) 0
$ removePathsCrossing a b $ foldr insertBlock w listBlocks
where
d = dist a b
rot = argV (b -.- a)
src/Dodge/LevelGen/TriggerDoor.hs
+17 -17
View File
@@ -1,9 +1,9 @@
--{-# LANGUAGE BangPatterns #-}
module Dodge.LevelGen.TriggerDoor
( putDoor
, putDoubleDoor
, putSingleDoor
, addButtonDoor
, insertDoubleDoor
) where
import Dodge.Data
import Dodge.Base
@@ -25,13 +25,14 @@ import Control.Lens
import Data.Graph.Inductive hiding ((&))
-- probably don't have to rebuild the entire graph, oh well
addButtonDoor :: Color -> Point2 -> Float -> Point2 -> Point2 -> Float -> World -> World
addButtonDoor :: Color -> Point2 -> Float -> Point2 -> Point2 -> Float -> World -> (Int, World)
addButtonDoor c btp btr a b speed w
= over buttons (IM.insert bid bt)
= (,) 0
. over buttons (IM.insert bid bt)
$ set pathPoints (foldr insertPoint IM.empty (labNodes newGraph))
$ set pathGraph newGraph
$ set pathGraphP newGraphPairs
$ putDoubleDoor False c cond a b speed w
$ (snd $ putSingleDoor False c cond a b speed w)
where
bid = IM.newKey $ _buttons w
cond w' = BtNoLabel == _btState (_buttons w' IM.! bid)
@@ -50,9 +51,8 @@ putDoor
-> [(Point2,Point2)] -- ^ Door positions, closed to open.
-- Bumped out up and down by 9, not widened
-> World
-> World
putDoor col cond pss w = addWalls w
& doors %~ addDoor
-> (Int,World)
putDoor col cond pss w = (drid, addWalls w & doors %~ addDoor)
where
drid = IM.newKey $ _doors w
addDoor = IM.insert drid $ Door'
@@ -99,13 +99,6 @@ doorMechanismStepwise nsteps drid wlids pss dr w
-- it is not at all clear that the zoning selects the correct walls
putDoubleDoor :: Bool -> Color -> (World -> Bool) -> Point2 -> Point2 -> Float -> World -> World
putDoubleDoor isPathable col cond a b speed
= putSingleDoor isPathable col cond a c speed
. putSingleDoor isPathable col cond b c speed
where
c = 0.5 *.* (a +.+ b)
-- TODO think about wall zoning, simplify!
doorMechanism :: Int -> Float -> [(Int,(Point2,Point2),(Point2,Point2))] -> Door' -> World -> World
doorMechanism drid speed wlidOpCps dr w
@@ -129,9 +122,16 @@ doorMechanism drid speed wlidOpCps dr w
& walls . ix wlid %~ moveDoorToward speed p
& (\w'' -> foldr (changeZonedWall (moveDoorToward speed p) wlid) w'' (zoneps zp))
putSingleDoor :: Bool -> Color -> (World -> Bool) -> Point2 -> Point2 -> Float -> World -> World
putSingleDoor isPathable col cond a b speed w = addWalls w
& doors %~ addDoor
insertDoubleDoor :: Bool -> Color -> (World -> Bool) -> Point2 -> Point2 -> Float -> World
-> World
insertDoubleDoor isPathable col cond a b speed
= snd . putSingleDoor isPathable col cond a (0.5 *.* (a +.+ b)) speed
. snd . putSingleDoor isPathable col cond b (0.5 *.* (a +.+ b)) speed
putSingleDoor :: Bool -> Color -> (World -> Bool) -> Point2 -> Point2 -> Float -> World
-> (Int, World)
putSingleDoor isPathable col cond a b speed w = (drid, addWalls w
& doors %~ addDoor)
where
drid = IM.newKey $ _doors w
addDoor = IM.insert drid $ Door'
src/Dodge/LightSources.hs
+7
View File
@@ -8,6 +8,7 @@ module Dodge.LightSources
, lampCoverWhen
, doubleLampCover
, verticalLampCover
, chain
)
where
import Dodge.Data
@@ -26,7 +27,13 @@ colorLightAt col pos i =
,_lsDir = 0
,_lsRad = 700
,_lsIntensity = col
,_lsPict = lightSourcePicture
}
lightSourcePicture :: LightSource -> Picture
lightSourcePicture ls = setLayer 1 . translate3 (_lsPos ls) . color col $ circleSolid 3
where
col = V4 r g b 1
V3 r g b = _lsIntensity ls
lightAt :: Point3 -> Int -> LightSource
lightAt = colorLightAt 0.75
src/Dodge/Render/Picture.hs
+1
View File
@@ -30,6 +30,7 @@ worldPictures w = pictures
,concatMapPic (_spPicture . dbArg _prDraw) $ _props w
,concatMapPic (crDraw w) . IM.filter crIsClose $ _creatures w
,concatMapPic (dbArg _ptDraw) $ _particles w
,concatMapPic (dbArg _lsPict) $ _lightSources w
,testPic w
,concatMapPic (_spPicture . floorItemSPic) $ _floorItems w
,concatMapPic clDraw $ _clouds w
src/Dodge/Room/Corridor.hs
+1 -1
View File
@@ -17,7 +17,7 @@ corridor = defaultRoom
, _rmLinks = lnks
, _rmPath = concatMap (doublePair . (,) (V2 20 60) . fst) lnks
, _rmPS =
[sPS (V2 20 40) 0 $ PutLS (lightAt (V3 0 0 50) 0) (lampPic 50)
[sPS (V2 20 40) 0 $ PutLS (lightAt (V3 0 0 50) 0)
,sPS (V2 0 0) 0 $ PutForeground $ highPipe 55 (V2 0 40) (V2 40 40)
]
, _rmBound = [ rectNSWE 50 30 0 40 ]
src/Dodge/Room/LongDoor.hs
+11 -6
View File
@@ -24,7 +24,7 @@ import Control.Lens
import Control.Monad.State
import Data.Tree
import qualified Data.Map as M
--import qualified Data.IntMap as IM
import qualified Data.IntMap as IM
twinSlowDoorRoom
:: Int -- ^ Door id
@@ -44,19 +44,24 @@ twinSlowDoorRoom drid w h x = defaultRoom
[ sPS (V2 0 (h/2)) 0 putLamp
, sPS (V2 25 5) 0 putLamp
, sPS (V2 (negate 25) 5) 0 putLamp
, sPS (V2 0 0) 0 $ PutSingleDoor col cond (V2 x 1) (V2 x h) 1
, sPS (V2 0 0) 0 $ PutSingleDoor col cond (V2 (-x) 1) (V2 (-x) h) 1
, sPS (V2 0 0) 0 $ PutSingleDoor col cond (V2 x 1) (V2 x h) 1
, Placement (PS (V2 0 0) 0 $ PutSingleDoor col cond (V2 (-x) 1) (V2 (-x) h) 1)
$ \did -> Just $ Placement (PS (V2 0 (h-1)) 0 $ PutLS (colorLightAt (V3 0.75 0 0) (V3 0 0 lampHeight) 0))
$ \lsid -> Just $ sPS (V2 0 (h-1)) 0 $ PutProp $ addColorChange lsid did $ lampCoverWhen (drmoving did) lampHeight
, sPS (V2 0 (h-5)) pi $ PutButton $ makeSwitch col red
(worldState %~ M.insert (DoorNumOpen drid) True )
(worldState %~ M.insert (DoorNumOpen drid) False)
, sPS (V2 0 (h-1)) 0 $ PutLS (colorLightAt (V3 0.75 0 0) (V3 0 0 lampHeight) 0) (lampPic lampHeight)
, sPS (V2 0 (h-1)) 0 $ PutProp $ lampCoverWhen drmoving lampHeight
]
, _rmBound = ps
, _rmName = "twinSlowDoorRoom"
}
where
drmoving _ = True -- DoorHalfway == _drStatus (_doors w' IM.! drid)
addColorChange lsid drid = over pjUpdate $ chain $ const f
where
f w' | _drStatus (_doors w' IM.! drid) == DoorHalfway
= w' & lightSources . ix lsid . lsIntensity .~ V3 8 0 0
| otherwise = w' & lightSources . ix lsid . lsIntensity .~ 0.7
drmoving i w' = DoorHalfway == _drStatus (_doors w' IM.! i)
lampHeight = 41
ps =
[rectNSWE h 0 (-w) w