166 lines
4.2 KiB
Haskell
166 lines
4.2 KiB
Haskell
module Dodge.LightSources.Lamp
|
|
( tLightTimedIntensity
|
|
, tLight
|
|
, lightAt
|
|
, colorLightAt
|
|
, lampCover
|
|
, lampCoverWhen
|
|
, doubleLampCover
|
|
, verticalLampCover
|
|
, chain
|
|
)
|
|
where
|
|
import Dodge.Data
|
|
import Geometry.Data
|
|
import ShapePicture
|
|
import Shape
|
|
import Geometry
|
|
import Dodge.Default
|
|
|
|
import Control.Lens
|
|
|
|
colorLightAt :: Point3 -> Point3 -> Int -> LightSource
|
|
colorLightAt col pos i =
|
|
LS {_lsID = i
|
|
,_lsPos = pos
|
|
,_lsDir = 0
|
|
,_lsRad = 700
|
|
,_lsIntensity = col
|
|
,_lsPict = defLSPic
|
|
}
|
|
|
|
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
|
|
|
|
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) -> Point2 -> Float -> Prop
|
|
lampCoverWhen cond pos h = ShapeProp
|
|
{ _pjPos = pos
|
|
, _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
|
|
, 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
|