diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index 1e71eee7d..8d09a4aa6 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -489,6 +489,13 @@ data Prop , _pjUpdate :: Prop -> World -> World , _pjTime :: Int } + | ShapeProp + { _pjPos :: Point2 + , _pjID :: Int + , _pjRot :: Float + , _pjUpdate :: Prop -> World -> World + , _prDraw :: Prop -> SPic + } | Shell { _pjPos :: Point2 , _pjStartPos :: Point2 diff --git a/src/Dodge/LevelGen.hs b/src/Dodge/LevelGen.hs index 883bee70f..2b27fe208 100644 --- a/src/Dodge/LevelGen.hs +++ b/src/Dodge/LevelGen.hs @@ -70,6 +70,7 @@ placeSpots pss w = foldr (placeSpot . _placementSpot) w' singlePlacements {- | -} placeSpot :: PlacementSpot -> World -> World placeSpot ps w = case _psType ps of + PutProp prop -> placeProp prop p rot w PutButton bt -> placeBt bt p rot w PutFlIt itm -> placeFlIt itm p rot w PutCrit cr -> placeCr cr p rot w @@ -146,6 +147,17 @@ addPane wl (p0,p1) wls = IM.insert (IM.newKey wls) (wl }) wls +-- TODO make rotation of props sensible +placeProp + :: Prop + -> Point2 + -> Float -- ^ Rotation + -> World + -> World +placeProp pr p a = over props addProp + where + addProp prs = IM.insert (IM.newKey prs) (over pjRot (+a) pr {_pjPos = p, _pjID = IM.newKey prs}) prs + placeBt :: Button -> Point2 diff --git a/src/Dodge/LevelGen/Data.hs b/src/Dodge/LevelGen/Data.hs index a7af6c1ec..717972db2 100644 --- a/src/Dodge/LevelGen/Data.hs +++ b/src/Dodge/LevelGen/Data.hs @@ -28,6 +28,7 @@ import System.Random data PSType = PutCrit {_unPutCrit :: Creature} | PutLS LightSource Picture | PutButton Button + | PutProp Prop | PutFlIt Item | PutPressPlate PressPlate | PutAutoDoor Point2 Point2 diff --git a/src/Dodge/LightSources.hs b/src/Dodge/LightSources.hs index 37be32be6..73a78b0e4 100644 --- a/src/Dodge/LightSources.hs +++ b/src/Dodge/LightSources.hs @@ -4,11 +4,15 @@ module Dodge.LightSources , lightAt , colorLightAt , lampPic + , lampCover ) where import Dodge.Data import Geometry.Data import Picture +import ShapePicture +import Shape +import Geometry import Control.Lens @@ -62,3 +66,31 @@ tLight t rmax col (V3 x y z) = TLS 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 = updateLampCover + , _prDraw = drawLampCover h + } + +updateLampCover :: Prop -> World -> World +updateLampCover pr w = w + & props . ix (_pjID pr) . pjRot +~ 0.15 + +drawLampCover :: Float -> Prop -> SPic +drawLampCover h pr = + ( translateSHz (h-2.5) . uncurryV translateSHf pos + $ rotateSH a $ mconcat + [ upperPrismPoly 5 $ rectNSEW 6 5 6 (-4) + , upperPrismPoly 5 $ rectNSEW 6 (-4) 6 5 + --, translateSHz 2.5 . upperPrismPoly 1 $ [V2 5 5,V2 (-4) 5,V2 5 (-4)] + , upperPrismPoly 1 $ [V2 5 5,V2 (-4) 5,V2 5 (-4)] + ] + , mempty + ) + where + a = _pjRot pr + pos = _pjPos pr diff --git a/src/Dodge/Room/Corridor.hs b/src/Dodge/Room/Corridor.hs index fcebb2e4c..93e7b678d 100644 --- a/src/Dodge/Room/Corridor.hs +++ b/src/Dodge/Room/Corridor.hs @@ -17,8 +17,8 @@ corridor = defaultRoom , _rmLinks = lnks , _rmPath = concatMap (doublePair . (,) (V2 20 60) . fst) lnks , _rmPS = - [ sPS (V2 20 40) 0 $ PutLS (lightAt (V3 0 0 50) 0) (lampPic 50) - , sPS (V2 0 0) 0 $ PutForeground $ highPipe 55 (V2 0 40) (V2 40 40) + [-- sPS (V2 20 40) 0 $ PutLS (lightAt (V3 0 0 50) 0) (lampPic 50) + sPS (V2 0 0) 0 $ PutForeground $ highPipe 55 (V2 0 40) (V2 40 40) ] , _rmBound = [ rectNSWE 50 30 0 40 ] , _rmFloor = [makeTileFromPoly poly 2] diff --git a/src/Dodge/Room/Start.hs b/src/Dodge/Room/Start.hs index 3285d608b..9246aa80c 100644 --- a/src/Dodge/Room/Start.hs +++ b/src/Dodge/Room/Start.hs @@ -8,6 +8,7 @@ import Dodge.Room.Placement import Dodge.Room.Foreground import Dodge.Layout.Tree.Polymorphic import Dodge.LevelGen.Data +import Dodge.LightSources --import Picture import Geometry.Data @@ -24,13 +25,21 @@ startRoom = do w <- state $ randomR (100,400) h <- state $ randomR (200,400) let fground = sPS (V2 0 0) 0 $ PutForeground $ - girderV 50 20 10 (V2 0 (h/5)) (V2 w (h/5)) - <> highPipe 40 (V2 0 (h/2)) (V2 w (h/3)) + 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) treeFromPost [Left rezBox, Left door] . Right <$> randomiseOutLinks (shiftRoomBy (V2 (-20) (-20),0) - $ roomRectAutoLinks w h & rmPS .~ [fground,theLamp]) + $ 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 + ] + ) + where + lampHeight = 41 -- where -- cola = dark . dark . light . light $ light red -- colb = dark . dark . light . light $ light blue