Prop reification/splitting
This commit is contained in:
@@ -16,36 +16,35 @@ import ShapePicture
|
||||
import Control.Lens
|
||||
import Data.Maybe
|
||||
|
||||
propLSThen :: (Prop -> World -> World)
|
||||
-> (Prop -> World -> LightSource -> LightSource)
|
||||
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 & pjUpdate .~ theupdate (fromJust $ _plMID lspl))
|
||||
$ \lspl -> Just $ pt0 (PutProp $ prop & prUpdate .~ PropUpdates [propf,PropUpdateLS (fromJust $ _plMID lspl) lsf])
|
||||
-- theupdate (fromJust $ _plMID lspl))
|
||||
$ cont lspl
|
||||
where
|
||||
theupdate lsid pr w = propf pr w & lightSources . ix lsid %~ lsf pr w
|
||||
--theupdate lsid pr w = propf pr w & lightSources . ix lsid %~ lsf pr w
|
||||
|
||||
moveLSThen :: (World -> (Point2,Float))
|
||||
moveLSThen :: WdP2f --(World -> (Point2,Float))
|
||||
-> Point3 -- ^ light source offset
|
||||
-> Shape
|
||||
-> (Placement -> Placement -> Maybe Placement)
|
||||
-> Placement
|
||||
moveLSThen posf off sh = propLSThen propupdate lsupdate thels theprop
|
||||
moveLSThen posf off sh = propLSThen (PropUpdatePosition posf) (PrWdLsSetPosition posf off) thels theprop
|
||||
where
|
||||
propupdate pr w = w
|
||||
& props . ix (_pjID pr) . prPos .~ fst (posf w)
|
||||
& props . ix (_pjID pr) . pjRot .~ snd (posf w)
|
||||
lsupdate _ w = lsParam . lsPos .~ addZ 0 (fst (posf w)) +.+.+ rotate3z (snd (posf w)) off
|
||||
--lsupdate _ w = lsParam . lsPos .~ addZ 0 (fst (posf w)) +.+.+ rotate3z (snd (posf w)) off
|
||||
thels = defaultLS
|
||||
theprop = ShapeProp
|
||||
{ _prPos = 0
|
||||
, _pjID = 0
|
||||
, _pjRot = 0
|
||||
, _pjUpdate = const id
|
||||
, _prDraw = \pr -> noPic $ uncurryV translateSHf (_prPos pr) $ rotateSH (_pjRot pr) sh
|
||||
, _prID = 0
|
||||
, _prRot = 0
|
||||
, _prUpdate = PropUpdateId
|
||||
--, _prDraw = PropDrawSPic $ noPic $ uncurryV translateSHf (_prPos pr) $ rotateSH (_pjRot pr) sh
|
||||
, _prDraw = PropDrawFlatTranslate $ PropDrawSPic $ noPic sh
|
||||
, _prToggle = True
|
||||
}
|
||||
|
||||
|
||||
@@ -1,85 +1,35 @@
|
||||
module Dodge.Placement.Instance.LightSource.Cover where
|
||||
import Dodge.Data
|
||||
import Dodge.Base
|
||||
import Geometry.Data
|
||||
import ShapePicture
|
||||
import Shape
|
||||
import Geometry
|
||||
import Dodge.Default.Prop
|
||||
|
||||
import Control.Lens
|
||||
|
||||
lampCover :: Float -> Prop
|
||||
lampCover h = ShapeProp
|
||||
{ _prPos = V2 0 0
|
||||
, _pjID = 0
|
||||
, _pjRot = 0
|
||||
, _pjUpdate = rotateProp 0.15
|
||||
, _prDraw = drawLampCover h
|
||||
, _prID = 0
|
||||
, _prRot = 0
|
||||
, _prUpdate = PropRotate 0.15
|
||||
, _prDraw = PropLampCover h
|
||||
, _prToggle = True
|
||||
}
|
||||
lampCoverWhen :: (World -> Bool) -> Point2 -> Float -> Prop
|
||||
lampCoverWhen cond pos h = defaultShapeProp
|
||||
lampCoverWhen :: WdBl -> Point2 -> Float -> Prop
|
||||
lampCoverWhen cond pos h = defaultProp
|
||||
{ _prPos = pos
|
||||
, _pjUpdate = setToggle cond `dbArgChain` rotateProp 0.15
|
||||
, _prDraw = drawLampCover h
|
||||
, _prUpdate = PropSetToggleAnd cond (PropRotate 0.15)
|
||||
, _prDraw = PropLampCover h
|
||||
, _prToggle = True
|
||||
}
|
||||
|
||||
doubleLampCover :: Float -> Prop
|
||||
doubleLampCover h = defaultShapeProp
|
||||
doubleLampCover h = defaultProp
|
||||
{ _prPos = V2 0 0
|
||||
, _pjUpdate = rotateProp 0.15
|
||||
, _prDraw = drawDoubleLampCover h
|
||||
, _prUpdate = PropRotate 0.15
|
||||
, _prDraw = PropDoubleLampCover h
|
||||
}
|
||||
|
||||
-- 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 = defaultShapeProp
|
||||
{ _pjUpdate = rotateProp 0.15
|
||||
, _prDraw = drawVerticalLampCover h
|
||||
verticalLampCover h = defaultProp
|
||||
{ _prUpdate = PropRotate 0.15
|
||||
, _prDraw = PropVerticalLampCover h
|
||||
}
|
||||
|
||||
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
|
||||
|
||||
drawLampCover :: Float -> Prop -> SPic
|
||||
drawLampCover h pr
|
||||
| not (_prToggle pr) = mempty
|
||||
| otherwise = ( translateSHz (h-2.5) . uncurryV translateSHf (_prPos pr)
|
||||
$ rotateSH (_pjRot pr) $ mconcat
|
||||
[ translateSHz 1 . upperPrismPoly 1 . reverse $ rectNSWE 3 2 (-1) 3
|
||||
, translateSHz 1 . upperPrismPoly 1 . reverse $ rectNSWE 3 (-1) 2 3
|
||||
, translateSHz 2 . upperPrismPoly 1 . reverse $ rectNSWE 3 2 (-1) 3
|
||||
, translateSHz 2 . upperPrismPoly 1 . reverse $ rectNSWE 3 (-1) 2 3
|
||||
, upperPrismPoly 1 [V2 2 2,V2 (-1) 2,V2 2 (-1)]
|
||||
]
|
||||
, mempty
|
||||
)
|
||||
|
||||
drawDoubleLampCover :: Float -> Prop -> SPic
|
||||
drawDoubleLampCover h pr =
|
||||
( translateSHz (h-2.5) . uncurryV translateSHf (_prPos pr)
|
||||
$ rotateSH (_pjRot pr) $ mconcat
|
||||
[ upperPrismPoly 5 $ reverse $ rectNSWE 6 5 (-6) 6
|
||||
, upperPrismPoly 5 $ reverse $ rectNSWE (-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
|
||||
)
|
||||
|
||||
drawVerticalLampCover :: Float -> Prop -> SPic
|
||||
drawVerticalLampCover h pr =
|
||||
( translateSHz h . uncurryV translateSHf (_prPos pr)
|
||||
$ rotateSHx (_pjRot pr) $ mconcat
|
||||
[
|
||||
translateSHz (-3) . upperPrismPoly 1 $ reverse $ rectNSWE 2 (-2) (-5) 5
|
||||
]
|
||||
, mempty
|
||||
)
|
||||
|
||||
@@ -86,7 +86,7 @@ placeSpotID :: PlacementSpot -> PSType -> World -> (Int, World)
|
||||
placeSpotID ps pt w = case pt of
|
||||
PutTrigger cnd -> plNewID triggers cnd w
|
||||
PutMod mdi -> plNewUpID modifications mdID mdi w
|
||||
PutProp prp -> plNewUpID props pjID (mvProp p rot prp) w
|
||||
PutProp prp -> plNewUpID props prID (mvProp p rot prp) w
|
||||
PutButton bt -> plNewUpID buttons btID (mvButton p rot bt) w
|
||||
PutTerminal tm -> plNewUpID terminals tmID tm w
|
||||
PutFlIt itm -> plNewUpID floorItems flItID (createFlIt p rot itm) w
|
||||
@@ -150,7 +150,7 @@ addPane wl w l = w & plNew walls wlID (wl & wlLine .~ l)
|
||||
-- wlid = IM.newKey (_walls w)
|
||||
|
||||
mvProp :: Point2 -> Float -> Prop -> Prop
|
||||
mvProp p a = (pjRot +~ a) . (prPos %~ ( (p +.+) . rotateV a ))
|
||||
mvProp p a = (prRot +~ a) . (prPos %~ ( (p +.+) . rotateV a ))
|
||||
|
||||
mvButton :: Point2 -> Float -> Button -> Button
|
||||
mvButton p a = (btRot +~ a) . (btPos %~ ( (p +.+) . rotateV a ))
|
||||
|
||||
Reference in New Issue
Block a user