Refactor, try to limit dependencies
This commit is contained in:
@@ -1,58 +1,70 @@
|
||||
module Dodge.Placement.Instance.LightSource where
|
||||
import Dodge.Data
|
||||
import Dodge.LightSource
|
||||
|
||||
import Color
|
||||
import Control.Lens
|
||||
import Data.Maybe
|
||||
import Dodge.Creature.Inanimate
|
||||
import Dodge.Data.GenWorld
|
||||
import Dodge.Default
|
||||
import Dodge.LevelGen.Data
|
||||
import Dodge.LightSource
|
||||
import Dodge.Room.Foreground
|
||||
import Geometry
|
||||
--import Geometry.Vector3D
|
||||
import Dodge.Creature.Inanimate
|
||||
import Shape.Data
|
||||
import Dodge.Default
|
||||
import RandomHelp
|
||||
import Color
|
||||
import Shape
|
||||
import ShapePicture
|
||||
|
||||
import Control.Lens
|
||||
import Data.Maybe
|
||||
propLSThen ::
|
||||
PropUpdate ->
|
||||
PrWdLsLs -> --(Prop -> World -> LightSource -> LightSource)
|
||||
LightSource ->
|
||||
Prop ->
|
||||
-- | continuation, access to ls and prop placements
|
||||
(Placement -> Placement -> Maybe Placement) ->
|
||||
Placement
|
||||
propLSThen propf lsf ls prop cont = pt0 (PutLS ls) $
|
||||
\lspl ->
|
||||
Just $
|
||||
pt0 (PutProp $ prop & prUpdate .~ PropUpdates [propf, PropUpdateLS (fromJust $ _plMID lspl) lsf]) $
|
||||
cont lspl
|
||||
|
||||
propLSThen :: PropUpdate
|
||||
-> PrWdLsLs --(Prop -> World -> LightSource -> LightSource)
|
||||
-> LightSource
|
||||
-> Prop
|
||||
-> (Placement -> Placement -> Maybe Placement) -- ^ continuation, access to ls and prop placements
|
||||
-> Placement
|
||||
propLSThen propf lsf ls prop cont = pt0 (PutLS ls)
|
||||
$ \lspl -> Just $ pt0 (PutProp $ prop & prUpdate .~ PropUpdates [propf,PropUpdateLS (fromJust $ _plMID lspl) lsf])
|
||||
$ cont lspl
|
||||
moveLSThen ::
|
||||
WdP2f -> --(World -> (Point2,Float))
|
||||
|
||||
moveLSThen :: WdP2f --(World -> (Point2,Float))
|
||||
-> Point3 -- ^ light source offset
|
||||
-> Shape
|
||||
-> (Placement -> Placement -> Maybe Placement)
|
||||
-> Placement
|
||||
-- | light source offset
|
||||
Point3 ->
|
||||
Shape ->
|
||||
(Placement -> Placement -> Maybe Placement) ->
|
||||
Placement
|
||||
moveLSThen posf off sh = propLSThen (PropUpdatePosition posf) (PrWdLsSetPosition posf off) thels theprop
|
||||
where
|
||||
--lsupdate _ w = lsParam . lsPos .~ addZ 0 (fst (posf w)) +.+.+ rotate3z (snd (posf w)) off
|
||||
thels = defaultLS
|
||||
theprop = ShapeProp
|
||||
{ _prPos = 0
|
||||
, _prID = 0
|
||||
, _prRot = 0
|
||||
, _prUpdate = PropUpdateId
|
||||
--, _prDraw = PropDrawSPic $ noPic $ uncurryV translateSHf (_prPos pr) $ rotateSH (_pjRot pr) sh
|
||||
, _prDraw = PropDrawFlatTranslate $ PropDrawSPic $ noPic sh
|
||||
, _prToggle = True
|
||||
}
|
||||
|
||||
theprop =
|
||||
ShapeProp
|
||||
{ _prPos = 0
|
||||
, _prID = 0
|
||||
, _prRot = 0
|
||||
, _prUpdate = PropUpdateId
|
||||
, --, _prDraw = PropDrawSPic $ noPic $ uncurryV translateSHf (_prPos pr) $ rotateSH (_pjRot pr) sh
|
||||
_prDraw = PropDrawFlatTranslate $ PropDrawSPic $ noPic sh
|
||||
, _prToggle = True
|
||||
}
|
||||
|
||||
-- | mount a light source on a shape
|
||||
mntLSOn
|
||||
:: (Point2 -> Point3 -> Shape) -- ^ function describing the mount shape
|
||||
-> Maybe Color -- ^ describing a possible color override for the shape
|
||||
-> LightSource -> Point2 -> Point3 -> (Placement -> Maybe Placement) -> Placement
|
||||
mntLSOn shapeF mcol ls wallp lsp@(V3 lx ly _)
|
||||
= ps0jPushPS (putShape . setCol $ shapeF wallp lsp)
|
||||
. pt0 (PutLS $ ls & lsParam . lsPos .~ lsp')
|
||||
mntLSOn ::
|
||||
-- | function describing the mount shape
|
||||
(Point2 -> Point3 -> Shape) ->
|
||||
-- | describing a possible color override for the shape
|
||||
Maybe Color ->
|
||||
LightSource ->
|
||||
Point2 ->
|
||||
Point3 ->
|
||||
(Placement -> Maybe Placement) ->
|
||||
Placement
|
||||
mntLSOn shapeF mcol ls wallp lsp@(V3 lx ly _) =
|
||||
ps0jPushPS (putShape . setCol $ shapeF wallp lsp)
|
||||
. pt0 (PutLS $ ls & lsParam . lsPos .~ lsp')
|
||||
where
|
||||
lsp' = lsp -.-.- V3 x y 1
|
||||
-- hack! perturb the light position
|
||||
@@ -63,17 +75,19 @@ iShape :: Point2 -> Point3 -> Shape
|
||||
iShape wp (V3 x y z) = thinHighBar z wp (V2 x y)
|
||||
|
||||
lShape :: Point2 -> Point3 -> Shape
|
||||
lShape wp (V3 x y z) = thinHighBar z wallposUp turnpos
|
||||
<> thinHighBar z turnpos (V2 x y)
|
||||
lShape wp (V3 x y z) =
|
||||
thinHighBar z wallposUp turnpos
|
||||
<> thinHighBar z turnpos (V2 x y)
|
||||
where
|
||||
n = vNormal (wp -.- V2 x y)
|
||||
wallposUp = wp +.+ n
|
||||
turnpos = V2 x y +.+ n
|
||||
|
||||
jShape :: Point2 -> Point3 -> Shape
|
||||
jShape wallpos (V3 x y z) = thinHighBar z wallposUp turn1
|
||||
<> thinHighBar z turn1 turn2
|
||||
<> thinHighBar z turn2 endpos
|
||||
jShape wallpos (V3 x y z) =
|
||||
thinHighBar z wallposUp turn1
|
||||
<> thinHighBar z turn1 turn2
|
||||
<> thinHighBar z turn2 endpos
|
||||
where
|
||||
n = vNormal (wallpos -.- V2 x y)
|
||||
wallposUp = wallpos +.+ n
|
||||
@@ -84,8 +98,8 @@ jShape wallpos (V3 x y z) = thinHighBar z wallposUp turn1
|
||||
|
||||
liShape :: Point2 -> Point3 -> Shape
|
||||
liShape wallpos (V3 x y z) =
|
||||
thinHighBar z wallposUp turnpos
|
||||
<> thinHighBar z turnpos (V2 x y)
|
||||
thinHighBar z wallposUp turnpos
|
||||
<> thinHighBar z turnpos (V2 x y)
|
||||
where
|
||||
n = vNormal (V2 x y -.- wallpos)
|
||||
wallposUp = wallpos +.+ n
|
||||
@@ -93,14 +107,14 @@ liShape wallpos (V3 x y z) =
|
||||
|
||||
aShape :: Point2 -> Point3 -> Shape
|
||||
aShape wallpos (V3 x y z) =
|
||||
girder (z+2) 20 10 pout wallpos
|
||||
girder (z + 2) 20 10 pout wallpos
|
||||
where
|
||||
pout = V2 x y -.- 2 *.* squashNormalizeV (V2 x y -.- wallpos)
|
||||
|
||||
vShape :: Point2 -> Point3 -> Shape
|
||||
vShape wallpos (V3 x y z) =
|
||||
thinHighBar z wallposUp lxy
|
||||
<> thinHighBar z wallposDown lxy
|
||||
<> thinHighBar z wallposDown lxy
|
||||
where
|
||||
lxy = V2 x y
|
||||
n = vNormal (wallpos -.- lxy)
|
||||
@@ -114,52 +128,65 @@ mntLSCol :: (Point2 -> Point3 -> Shape) -> Color -> Point2 -> Point3 -> Placemen
|
||||
mntLSCol shp col wallp lampp = mntLSOn shp (Just col) defaultLS wallp lampp (const Nothing)
|
||||
|
||||
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)
|
||||
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
|
||||
|
||||
mntLSCond :: (Point2 -> Point3 -> Shape)
|
||||
-- -> (RoomPos -> Room -> Maybe (PlacementSpot,RoomPos))
|
||||
-> PlacementSpot
|
||||
-> Placement
|
||||
mntLSCond shp ps = -- updatePSToLevel 1 (const $ PSLnk shift (const id) Nothing) $
|
||||
mntLSCond ::
|
||||
(Point2 -> Point3 -> Shape) ->
|
||||
-- -> (RoomPos -> Room -> Maybe (PlacementSpot,RoomPos))
|
||||
PlacementSpot ->
|
||||
Placement
|
||||
mntLSCond shp ps =
|
||||
-- updatePSToLevel 1 (const $ PSLnk shift (const id) Nothing) $
|
||||
mntLS shp 0 (V3 0 (-20) 95)
|
||||
& plSpot .~ ps
|
||||
-- note that this perhaps pushes the vshape light out too far
|
||||
& plSpot .~ ps
|
||||
|
||||
-- note that this perhaps pushes the vshape light out too far
|
||||
|
||||
mntLight :: Point2 -> Point2 -> Placement
|
||||
mntLight a b = RandomPlacement $ do
|
||||
shp <- takeOne [vShape,iShape,lShape,jShape,liShape]
|
||||
shp <- takeOne [vShape, iShape, lShape, jShape, liShape]
|
||||
return $ mntLS shp a (addZ 90 b)
|
||||
|
||||
mntLightLnkCond :: PlacementSpot -> Placement
|
||||
mntLightLnkCond ps = RandomPlacement $ do
|
||||
shp <- takeOne [vShape,lShape,jShape,liShape]
|
||||
shp <- takeOne [vShape, lShape, jShape, liShape]
|
||||
return $ mntLSCond (fmap (fmap $ colorSH black) shp) ps
|
||||
|
||||
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
|
||||
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 = Placement 10 (PS (V2 x y) 0) (PutLS ls) Nothing
|
||||
$ const $ const $ Just $ sps0 $ putShape $ thinHighBar h a b
|
||||
spanLS ls a b =
|
||||
Placement 10 (PS (V2 x y) 0) (PutLS ls) Nothing $
|
||||
const $ const $ Just $ sps0 $ putShape $ thinHighBar h a b
|
||||
where
|
||||
V3 _ _ h = _lsPos (_lsParam ls) + 5
|
||||
V2 x y = 0.5 *.* (a +.+ b)
|
||||
|
||||
spanColLightI :: Point3 -> Float -> Point2 -> Point2 -> Placement
|
||||
spanColLightI col h a b = ps0j (PutLS $ lsColPos col (V3 x y (h-5)))
|
||||
$ sps0 $ putShape $ thinHighBar h a b
|
||||
spanColLightI col h a b =
|
||||
ps0j (PutLS $ lsColPos col (V3 x y (h -5))) $
|
||||
sps0 $ putShape $ thinHighBar h a b
|
||||
where
|
||||
V2 x y = 0.5 *.* (a +.+ b)
|
||||
|
||||
spanColLightBlackI :: Point3 -> Float -> Point2 -> Point2 -> Placement
|
||||
spanColLightBlackI col h a b = ps0j (PutLS $ lsColPos col (V3 x y (h-5)))
|
||||
$ sps0 $ putShape $ colorSH black $ thinHighBar h a b
|
||||
spanColLightBlackI col h a b =
|
||||
ps0j (PutLS $ lsColPos col (V3 x y (h -5))) $
|
||||
sps0 $ putShape $ colorSH black $ thinHighBar h a b
|
||||
where
|
||||
V2 x y = 0.5 *.* (a +.+ b)
|
||||
|
||||
|
||||
Reference in New Issue
Block a user