Working implementation of light change when door opens
This commit is contained in:
+37
-33
@@ -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
|
||||
|
||||
Reference in New Issue
Block a user