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

Add light fittings

Browse Source
This commit is contained in:
justin
2021-09-29 19:07:02 +01:00
parent f3437adef7
commit d7f975d40e
10 changed files with 252 additions and 192 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Creature/Inanimate.hs
+1 -1
View File
@@ -11,7 +11,7 @@ import Dodge.Creature.State.Data
import Dodge.Picture.Layer
import Dodge.Default
import Dodge.Creature.State
import Dodge.LightSources
import Dodge.LightSources.Lamp
import Dodge.WorldEvent.Flash
import Dodge.WorldEvent.Sound
import Dodge.Creature.Update
src/Dodge/LightSources.hs
-174
View File
@@ -1,176 +1,2 @@
module Dodge.LightSources
( tLightTimedIntensity
, tLight
, lightAt
, colorLightAt
, lampPic
, lampCover
, lampCoverWhen
, doubleLampCover
, verticalLampCover
, chain
)
where
import Dodge.Data
import Geometry.Data
import Picture
import ShapePicture
import Shape
import Geometry
import Control.Lens
colorLightAt :: Point3 -> Point3 -> Int -> LightSource
colorLightAt col pos i =
LS {_lsID = i
,_lsPos = pos
,_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
tLightTimedIntensity :: Int -> Float -> (Int -> Float) -> Point2 -> TempLightSource
tLightTimedIntensity t rmax intensityF (V2 x y) = TLS
{ _tlsPos = V3 x y 0
, _tlsRad = rmax
, _tlsIntensity = f $ intensityF t
, _tlsUpdate = upF
, _tlsTime = t
}
where
upF _ tls
| _tlsTime tls <= 0 = Nothing
| otherwise = Just $ tls
& tlsTime -~ 1
& tlsIntensity .~ f (intensityF (_tlsTime tls) )
f x' = V3 x' x' x'
tLight
:: Int
-> Float -- ^ maximal radius
-> Point3
-> Point3
-> TempLightSource
tLight t rmax col (V3 x y z) = TLS
{ _tlsPos = V3 x y z
, _tlsRad = rmax
, _tlsIntensity = col
, _tlsUpdate = upF
, _tlsTime = t
}
where
upF _ tls
| _tlsTime tls <= 0 = Nothing
| otherwise = Just $ tls
& tlsTime -~ 1
lampPic :: Float -> Picture
--{-# INLINE lampPic #-}
lampPic h = setLayer 1 (setDepth h . color white $ circleSolid 3)
lampCover :: Float -> Prop
lampCover h = ShapeProp
{ _pjPos = V2 0 0
, _pjID = 0
, _pjRot = 0
, _pjUpdate = rotateProp 0.15
, _prDraw = drawLampCover h
, _prToggle = True
}
lampCoverWhen :: (World -> Bool) -> Float -> Prop
lampCoverWhen cond h = ShapeProp
{ _pjPos = V2 0 0
, _pjID = 0
, _pjRot = 0
, _pjUpdate = setToggle cond `chain` rotateProp 0.15
, _prDraw = drawLampCover h
, _prToggle = True
}
doubleLampCover :: Float -> Prop
doubleLampCover h = ShapeProp
{ _pjPos = V2 0 0
, _pjID = 0
, _pjRot = 0
, _pjUpdate = rotateProp 0.15
, _prDraw = drawDoubleLampCover h
, _prToggle = True
}
-- on the current (27/9/21) version of shadow stencilling, this glitches
-- slightly when the shadow rotates towards the screen
verticalLampCover :: Float -> Prop
verticalLampCover h = ShapeProp
{ _pjPos = V2 0 0
, _pjID = 0
, _pjRot = 0
, _pjUpdate = rotateProp 0.15
, _prDraw = drawVerticalLampCover h
, _prToggle = True
}
rotateProp :: Float -> Prop -> World -> World
rotateProp rotAmount pr w = w
& props . ix (_pjID pr) . pjRot +~ rotAmount
setToggle :: (World -> Bool) -> Prop -> World -> World
setToggle cond pr w = w & props . ix (_pjID pr) . prToggle .~ cond w
-- TODO check whether this is simply the reader monad, flipped
chain :: (a -> b -> b) -> (a -> b -> b) -> a -> b -> b
chain f g x = f x . g x
drawLampCover :: Float -> Prop -> SPic
drawLampCover h pr | not (_prToggle pr) = mempty
| otherwise =
( translateSHz (h-2.5) . uncurryV translateSHf pos
$ rotateSH a $ mconcat
[ translateSHz 1 . upperPrismPoly 1 $ rectNSEW 3 2 3 (-1)
, translateSHz 1 . upperPrismPoly 1 $ rectNSEW 3 (-1) 3 2
, translateSHz 2 . upperPrismPoly 1 $ rectNSEW 3 2 3 (-1)
, translateSHz 2 . upperPrismPoly 1 $ rectNSEW 3 (-1) 3 2
--, translateSHz 2.5 . upperPrismPoly 1 $ [V2 5 5,V2 (-4) 5,V2 5 (-4)]
, upperPrismPoly 1 [V2 2 2,V2 (-1) 2,V2 2 (-1)]
]
, mempty
)
where
a = _pjRot pr
pos = _pjPos pr
drawDoubleLampCover :: Float -> Prop -> SPic
drawDoubleLampCover h pr =
( translateSHz (h-2.5) . uncurryV translateSHf pos
$ rotateSH a $ mconcat
[ upperPrismPoly 5 $ rectNSEW 6 5 6 (-6)
, upperPrismPoly 5 $ rectNSEW (-5) (-6) 6 (-6)
, upperPrismPoly 1 [V2 0 (-1),V2 6 5,V2 (-6) 5]
, upperPrismPoly 1 [V2 0 1 ,V2 (-6) (-5),V2 6 (-5)]
]
, mempty
)
where
a = _pjRot pr
pos = _pjPos pr
drawVerticalLampCover :: Float -> Prop -> SPic
drawVerticalLampCover h pr =
( translateSHz h . uncurryV translateSHf pos
$ rotateSHx a $ mconcat
[
translateSHz (-3) . upperPrismPoly 1 $ rectNSEW 2 (-2) 5 (-5)
]
, mempty
)
where
a = _pjRot pr
pos = _pjPos pr
src/Dodge/LightSources/Fitting.hs
+60
View File
@@ -0,0 +1,60 @@
module Dodge.LightSources.Fitting
where
import Dodge.LightSources.Lamp
import Dodge.LevelGen.Data
import Dodge.Room.Foreground
import Geometry
wallMount :: Point2 -> Point3 -> Placement
wallMount wallPos lampPos@(V3 x y z)
= Placement (PS (V2 0 0) 0 $ PutForeground $ highBar (z+5) wallPos pout)
$ \_ -> Just $ sPS (V2 0 0) 0 $ PutLS (colorLightAt 0.75 lampPos 0)
where
pout = V2 x y +.+ safeNormalizeV (V2 x y -.- wallPos)
wallMountL :: Point2 -> Point3 -> Placement
wallMountL wallpos lamppos@(V3 x y z)
= place0 (PutLS $ colorLightAt 0.75 lamppos 0)
$ \_ -> jsps0 $ PutForeground $ highBar (z + 5) wallposUp (turnpos `extendAway` wallposUp)
<> highBar (z + 5) turnpos (V2 x y `extendAway` turnpos)
where
n = vNormal (wallpos -.- V2 x y)
wallposUp = wallpos +.+ n
turnpos = V2 x y +.+ n
wallMountl :: Point2 -> Point3 -> Placement
wallMountl wallpos lamppos@(V3 x y z)
= place0 (PutLS $ colorLightAt 0.75 lamppos 0)
$ \_ -> jsps0 $ PutForeground $ highBar (z + 5) wallposUp (turnpos `extendAway` wallposUp)
<> highBar (z + 5) turnpos (V2 x y `extendAway` turnpos)
where
n = vNormal (V2 x y -.- wallpos)
wallposUp = wallpos +.+ n
turnpos = V2 x y +.+ n
wallMountA :: Point2 -> Point3 -> Placement
wallMountA wallpos lamppos@(V3 x y z)
= place0 (PutLS $ colorLightAt 0.75 lamppos 0)
$ \_ -> jsps0 $ PutForeground $ girder (z+10) 20 10 pout wallpos
where
pout = V2 x y -.- 2 *.* safeNormalizeV (V2 x y -.- wallpos)
wallMountV :: Point2 -> Point3 -> Placement
wallMountV wallpos lamppos@(V3 x y z)
= place0 (PutLS $ colorLightAt 0.75 lamppos 0)
$ \_ -> jsps0 $ PutForeground $ highBar (z + 5) wallposUp (lxy `extendAway` wallposUp)
<> highBar (z + 5) wallposDown (lxy `extendAway` wallposDown)
where
lxy = V2 x y
n = vNormal (wallpos -.- lxy)
wallposUp = wallpos +.+ n
wallposDown = wallpos -.- n
extendAway :: Point2 -> Point2 -> Point2
extendAway p x = p +.+ safeNormalizeV (p -.- x)
jsps0 :: PSType -> Maybe Placement
jsps0 pst = Just $ sPS (V2 0 0) 0 pst
place0 :: PSType -> (Int -> Maybe Placement) -> Placement
place0 pst plm = Placement (PS (V2 0 0) 0 pst) plm
src/Dodge/LightSources/Lamp.hs
+176
View File
@@ -0,0 +1,176 @@
module Dodge.LightSources.Lamp
( tLightTimedIntensity
, tLight
, lightAt
, colorLightAt
, lampPic
, lampCover
, lampCoverWhen
, doubleLampCover
, verticalLampCover
, chain
)
where
import Dodge.Data
import Geometry.Data
import Picture
import ShapePicture
import Shape
import Geometry
import Control.Lens
colorLightAt :: Point3 -> Point3 -> Int -> LightSource
colorLightAt col pos i =
LS {_lsID = i
,_lsPos = pos
,_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
tLightTimedIntensity :: Int -> Float -> (Int -> Float) -> Point2 -> TempLightSource
tLightTimedIntensity t rmax intensityF (V2 x y) = TLS
{ _tlsPos = V3 x y 0
, _tlsRad = rmax
, _tlsIntensity = f $ intensityF t
, _tlsUpdate = upF
, _tlsTime = t
}
where
upF _ tls
| _tlsTime tls <= 0 = Nothing
| otherwise = Just $ tls
& tlsTime -~ 1
& tlsIntensity .~ f (intensityF (_tlsTime tls) )
f x' = V3 x' x' x'
tLight
:: Int
-> Float -- ^ maximal radius
-> Point3
-> Point3
-> TempLightSource
tLight t rmax col (V3 x y z) = TLS
{ _tlsPos = V3 x y z
, _tlsRad = rmax
, _tlsIntensity = col
, _tlsUpdate = upF
, _tlsTime = t
}
where
upF _ tls
| _tlsTime tls <= 0 = Nothing
| otherwise = Just $ tls
& tlsTime -~ 1
lampPic :: Float -> Picture
--{-# INLINE lampPic #-}
lampPic h = setLayer 1 (setDepth h . color white $ circleSolid 3)
lampCover :: Float -> Prop
lampCover h = ShapeProp
{ _pjPos = V2 0 0
, _pjID = 0
, _pjRot = 0
, _pjUpdate = rotateProp 0.15
, _prDraw = drawLampCover h
, _prToggle = True
}
lampCoverWhen :: (World -> Bool) -> Float -> Prop
lampCoverWhen cond h = ShapeProp
{ _pjPos = V2 0 0
, _pjID = 0
, _pjRot = 0
, _pjUpdate = setToggle cond `chain` rotateProp 0.15
, _prDraw = drawLampCover h
, _prToggle = True
}
doubleLampCover :: Float -> Prop
doubleLampCover h = ShapeProp
{ _pjPos = V2 0 0
, _pjID = 0
, _pjRot = 0
, _pjUpdate = rotateProp 0.15
, _prDraw = drawDoubleLampCover h
, _prToggle = True
}
-- on the current (27/9/21) version of shadow stencilling, this glitches
-- slightly when the shadow rotates towards the screen
verticalLampCover :: Float -> Prop
verticalLampCover h = ShapeProp
{ _pjPos = V2 0 0
, _pjID = 0
, _pjRot = 0
, _pjUpdate = rotateProp 0.15
, _prDraw = drawVerticalLampCover h
, _prToggle = True
}
rotateProp :: Float -> Prop -> World -> World
rotateProp rotAmount pr w = w
& props . ix (_pjID pr) . pjRot +~ rotAmount
setToggle :: (World -> Bool) -> Prop -> World -> World
setToggle cond pr w = w & props . ix (_pjID pr) . prToggle .~ cond w
-- TODO check whether this is simply the reader monad, flipped
chain :: (a -> b -> b) -> (a -> b -> b) -> a -> b -> b
chain f g x = f x . g x
drawLampCover :: Float -> Prop -> SPic
drawLampCover h pr | not (_prToggle pr) = mempty
| otherwise =
( translateSHz (h-2.5) . uncurryV translateSHf pos
$ rotateSH a $ mconcat
[ translateSHz 1 . upperPrismPoly 1 $ rectNSEW 3 2 3 (-1)
, translateSHz 1 . upperPrismPoly 1 $ rectNSEW 3 (-1) 3 2
, translateSHz 2 . upperPrismPoly 1 $ rectNSEW 3 2 3 (-1)
, translateSHz 2 . upperPrismPoly 1 $ rectNSEW 3 (-1) 3 2
--, translateSHz 2.5 . upperPrismPoly 1 $ [V2 5 5,V2 (-4) 5,V2 5 (-4)]
, upperPrismPoly 1 [V2 2 2,V2 (-1) 2,V2 2 (-1)]
]
, mempty
)
where
a = _pjRot pr
pos = _pjPos pr
drawDoubleLampCover :: Float -> Prop -> SPic
drawDoubleLampCover h pr =
( translateSHz (h-2.5) . uncurryV translateSHf pos
$ rotateSH a $ mconcat
[ upperPrismPoly 5 $ rectNSEW 6 5 6 (-6)
, upperPrismPoly 5 $ rectNSEW (-5) (-6) 6 (-6)
, upperPrismPoly 1 [V2 0 (-1),V2 6 5,V2 (-6) 5]
, upperPrismPoly 1 [V2 0 1 ,V2 (-6) (-5),V2 6 (-5)]
]
, mempty
)
where
a = _pjRot pr
pos = _pjPos pr
drawVerticalLampCover :: Float -> Prop -> SPic
drawVerticalLampCover h pr =
( translateSHz h . uncurryV translateSHf pos
$ rotateSHx a $ mconcat
[
translateSHz (-3) . upperPrismPoly 1 $ rectNSEW 2 (-2) 5 (-5)
]
, mempty
)
where
a = _pjRot pr
pos = _pjPos pr
src/Dodge/Prop.hs
+3
View File
@@ -0,0 +1,3 @@
module Dodge.Prop
where
src/Dodge/Room/Corridor.hs
+1 -1
View File
@@ -4,7 +4,7 @@ import Dodge.Room.Data
import Dodge.Room.Foreground
import Dodge.Default.Room
import Dodge.LevelGen.Data
import Dodge.LightSources
import Dodge.LightSources.Lamp
import Geometry
import Tile
src/Dodge/Room/LongDoor.hs
+3 -3
View File
@@ -15,7 +15,7 @@ import Dodge.LevelGen.Switch
import Dodge.RandomHelp
import Dodge.Creature.Inanimate
import Dodge.Creature
import Dodge.LightSources
import Dodge.LightSources.Lamp
import Picture
import Geometry
@@ -56,9 +56,9 @@ twinSlowDoorRoom drid w h x = defaultRoom
, _rmName = "twinSlowDoorRoom"
}
where
addColorChange lsid drid = over pjUpdate $ chain $ const f
addColorChange lsid drid' = over pjUpdate $ chain $ const f
where
f w' | _drStatus (_doors w' IM.! drid) == DoorHalfway
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)
src/Dodge/Room/Start.hs
+6 -11
View File
@@ -4,11 +4,11 @@ import Dodge.Room.Data
import Dodge.Room.Door
import Dodge.Room.Link
import Dodge.Room.Procedural
import Dodge.Room.Placement
--import Dodge.Room.Placement
import Dodge.Room.Foreground
import Dodge.Layout.Tree.Polymorphic
import Dodge.LevelGen.Data
--import Dodge.LightSources
import Dodge.LightSources.Fitting
--import Picture
import Geometry.Data
@@ -25,18 +25,13 @@ startRoom = do
w <- state $ randomR (100,400)
h <- state $ randomR (200,400)
let fground = sPS (V2 0 0) 0 $ PutForeground $
girderV 40 20 10 (V2 0 (h/6)) (V2 w (h/6))
<> highPipe 40 (V2 0 (h/2)) (V2 w (h/2))
<> highPipe 60 (V2 (w/3) 0 ) (V2 (w/3) h )
theLamp = sPS (V2 (w/2) (h/2)) 0 $ putColorLamp (V3 0.75 0.75 0.75)
girderV 40 20 10 (V2 0 (h/2)) (V2 w (h/2))
-- <> highPipe 40 (V2 0 (h/2)) (V2 w (h/2))
-- <> highPipe 60 (V2 (w/3) 0 ) (V2 (w/3) h )
treeFromPost [Left rezBox, Left door] . Right
<$> randomiseOutLinks (shiftRoomBy (V2 (-20) (-20),0)
$ roomRectAutoLinks w h & rmPS .~
[ fground
, theLamp
--, sPS (V2 100 100) 0 $ PutLS (colorLightAt (V3 0.75 0 0) (V3 0 0 lampHeight) 0) (lampPic lampHeight)
--, sPS (V2 100 100) 0 $ PutProp $ lampCover lampHeight
, wallMountA (V2 0 (h/3)) (V3 40 (h/3) 70)
]
)
where
--lampHeight = 41
src/Dodge/WorldEvent.hs
+1 -1
View File
@@ -18,7 +18,7 @@ import Dodge.WorldEvent.HitEffect
import Dodge.WorldEvent.Explosion
import Dodge.WorldEvent.SpawnParticle
--import Dodge.WorldEvent.Shockwave
import Dodge.LightSources
import Dodge.LightSources.Lamp
import Dodge.Creature.State.Data
import Dodge.Data
import Dodge.Data.DamageType
src/Dodge/WorldEvent/Flash.hs
+1 -1
View File
@@ -13,7 +13,7 @@ module Dodge.WorldEvent.Flash
import Dodge.Data
--import Dodge.Base
import Dodge.Picture
import Dodge.LightSources
import Dodge.LightSources.Lamp
import Dodge.WorldEvent.ThingsHit
import Dodge.WorldEvent.HelperParticle
import Picture