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

Continue work on chasm rooms

Browse Source
This commit is contained in:
justin
2025-10-03 11:52:49 +01:00
parent 7e3614c9c8
commit 5c22ca6662
11 changed files with 426 additions and 326 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Placement/Instance/LightSource.hs
+45 -31
View File
@@ -1,4 +1,17 @@
module Dodge.Placement.Instance.LightSource where
module Dodge.Placement.Instance.LightSource (
mntLSOn,
aShape,
mntLightLnkCond,
mntLS,
vShape,
iShape,
putLamp,
spanColLightBlackI,
moveLSThen,
spanLightI,
mntLightLnkCond',
spanLS,
) where
import Color
import Control.Lens
@@ -62,6 +75,7 @@ mntLSOn ::
(Placement -> Maybe Placement) ->
Placement
mntLSOn shapeF mcol ls wallp lsp@(V3 lx ly _) =
ps0jPushPS (PutLabel "light") .
ps0jPushPS (putShape . setCol $ shapeF wallp lsp)
. pt0 (PutLS $ ls & lsParam . lsPos .~ lsp')
where
@@ -125,23 +139,23 @@ mntLS shp wallp lampp = mntLSOn shp Nothing defaultLS wallp lampp (const Nothing
where
defaultLS = LS 0 $ LSParam 0 300 0.6
mntLSCol :: (Point2 -> Point3 -> Shape) -> Color -> Point2 -> Point3 -> Placement
mntLSCol shp col wallp lampp = mntLSOn shp (Just col) defaultLS wallp lampp (const Nothing)
where
defaultLS = LS 0 $ LSParam 0 200 0.6
--mntLSCol :: (Point2 -> Point3 -> Shape) -> Color -> Point2 -> Point3 -> Placement
--mntLSCol shp col wallp lampp = mntLSOn shp (Just col) defaultLS wallp lampp (const Nothing)
-- where
-- defaultLS = LS 0 $ LSParam 0 200 0.6
mntLSLampCol :: (Point2 -> Point3 -> Shape) -> Color -> Point2 -> Point3 -> Placement
mntLSLampCol shp (V4 x y z _) wallp lampp =
mntLSOn
shp
Nothing
(defaultLS & lsParam . lsCol .~ col)
wallp
lampp
(const Nothing)
where
col = V3 x y z
defaultLS = LS 0 $ LSParam 0 200 0.6
--mntLSLampCol :: (Point2 -> Point3 -> Shape) -> Color -> Point2 -> Point3 -> Placement
--mntLSLampCol shp (V4 x y z _) wallp lampp =
-- mntLSOn
-- shp
-- Nothing
-- (defaultLS & lsParam . lsCol .~ col)
-- wallp
-- lampp
-- (const Nothing)
-- where
-- col = V3 x y z
-- defaultLS = LS 0 $ LSParam 0 200 0.6
mntLSCond ::
(Point2 -> Point3 -> Shape) ->
@@ -155,10 +169,10 @@ mntLSCond shp ps =
-- note that this perhaps pushes the vshape light out too far
mntLight :: RandomGen g => Point2 -> Point2 -> State g Placement
mntLight a b = do
shp <- takeOne [vShape, iShape, lShape, jShape, liShape]
return $ mntLS shp a (addZ 90 b)
--mntLight :: RandomGen g => Point2 -> Point2 -> State g Placement
--mntLight a b = do
-- shp <- takeOne [vShape, iShape, lShape, jShape, liShape]
-- return $ mntLS shp a (addZ 90 b)
mntLightLnkCond :: RandomGen g => PlacementSpot -> State g Placement
mntLightLnkCond ps = do
@@ -168,12 +182,12 @@ mntLightLnkCond ps = do
mntLightLnkCond' :: PlacementSpot -> Placement
mntLightLnkCond' = mntLSCond (fmap (fmap $ colorSH black) vShape)
spanLSLightI :: LightSource -> Float -> Point2 -> Point2 -> Placement
spanLSLightI ls h a b =
ps0j (PutLS $ ls & lsParam . lsPos .~ V3 x y h) $
sps0 $ putShape $ thinHighBar h a b
where
V2 x y = 0.5 *.* (a +.+ b)
--spanLSLightI :: LightSource -> Float -> Point2 -> Point2 -> Placement
--spanLSLightI ls h a b =
-- ps0j (PutLS $ ls & lsParam . lsPos .~ V3 x y h) $
-- sps0 $ putShape $ thinHighBar h a b
-- where
-- V2 x y = 0.5 *.* (a +.+ b)
spanLS :: LightSource -> Point2 -> Point2 -> Placement
spanLS ls a b =
@@ -200,11 +214,11 @@ spanColLightBlackI col h a b =
spanLightI :: Point2 -> Point2 -> Placement
spanLightI = spanColLightI 0.75 50
extendAway :: Point2 -> Point2 -> Point2
extendAway p x = p +.+ squashNormalizeV (p -.- x)
--extendAway :: Point2 -> Point2 -> Point2
--extendAway p x = p +.+ squashNormalizeV (p -.- x)
putColorLamp :: Point3 -> PSType
putColorLamp col = PutCrit (colorLamp col 90)
--putColorLamp :: Point3 -> PSType
--putColorLamp col = PutCrit (colorLamp col 90)
putLamp :: PSType
putLamp = PutCrit (lamp 90)