From 96c72ef5783fdab3875c620f6be107de2e5e33ae Mon Sep 17 00:00:00 2001 From: justin Date: Sat, 13 Nov 2021 12:31:11 +0000 Subject: [PATCH] Cleanup light mounts --- src/Dodge/Placements/Button.hs | 4 +- src/Dodge/Placements/LightSource.hs | 139 +++++++++++----------------- src/Dodge/Placements/Spot.hs | 2 + src/Dodge/Room/Airlock.hs | 8 +- src/Dodge/Room/Boss.hs | 4 +- src/Dodge/Room/Procedural.hs | 16 ++-- src/Dodge/Room/RoadBlock.hs | 2 +- src/Dodge/Room/Room.hs | 8 +- src/Dodge/Room/Start.hs | 5 +- src/Dodge/Room/Treasure.hs | 2 +- 10 files changed, 80 insertions(+), 110 deletions(-) diff --git a/src/Dodge/Placements/Button.hs b/src/Dodge/Placements/Button.hs index 236d00fc2..930d8be60 100644 --- a/src/Dodge/Placements/Button.hs +++ b/src/Dodge/Placements/Button.hs @@ -21,7 +21,7 @@ externalButton col ps = pContID ps (PutTrigger (const False)) offeff tid = triggers . ix tid .~ const False putLitButtonID :: Color -> Point2 -> Float -> (Int -> Maybe Placement) -> Placement -putLitButtonID col p a subpl = mountLightAID (Just col) ls p'' (addZ 40 p') +putLitButtonID col p a subpl = mntLSOn aShape (Just col) ls p'' (addZ 40 p') $ \lsid -> jps0 (PutButton (makeButton col (changeLight lsid)) {_btPos = p, _btRot = a}) subpl where @@ -32,7 +32,7 @@ putLitButtonID col p a subpl = mountLightAID (Just col) ls p'' (addZ 40 p') putLitButtonID' :: Color -> ((Point2,Float) -> Bool) -> (Int -> Maybe Placement) -> Placement putLitButtonID' col f subpl - = updatePSToLevel 3 (const thePS) $ mountLightAID (Just col) ls 0 (V3 0 (-40) 40) + = updatePSToLevel 3 (const thePS) $ mntLSOn aShape (Just col) ls 0 (V3 0 (-40) 40) $ \lsid -> jps0 (PutButton (makeButton col (changeLight lsid)) {_btPos = V2 0 (-1), _btRot = pi}) subpl where diff --git a/src/Dodge/Placements/LightSource.hs b/src/Dodge/Placements/LightSource.hs index 3495fab13..3d926e072 100644 --- a/src/Dodge/Placements/LightSource.hs +++ b/src/Dodge/Placements/LightSource.hs @@ -1,5 +1,4 @@ -module Dodge.Placements.LightSource - where +module Dodge.Placements.LightSource where import Dodge.Data import Dodge.LightSources.Lamp import Dodge.LevelGen.Data @@ -14,11 +13,12 @@ import Dodge.RandomHelp import Color import Shape -mountLightOnShape +-- | 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 -> (Int -> Maybe Placement) -> Placement -mountLightOnShape shapeF mcol ls wallp lsp@(V3 lx ly _) +mntLSOn shapeF mcol ls wallp lsp@(V3 lx ly _) = ps0j (PutForeground . setCol $ shapeF wallp lsp) . ps0 (PutLS $ ls {_lsPos = lsp'}) where @@ -27,106 +27,75 @@ mountLightOnShape shapeF mcol ls wallp lsp@(V3 lx ly _) V2 x y = rotateV 1 . (0.1 *.*) . normalizeV $ wallp -.- V2 lx ly setCol = maybe id colorSH mcol -mountLightID :: Maybe Color -> LightSource -> Point2 -> Point3 -> (Int -> Maybe Placement) -> Placement -mountLightID = mountLightOnShape f - where - f wp (V3 x y z) = thinHighBar z wp (V2 x y) - redMID :: (Maybe Color -> LightSource -> Point2 -> Point3 -> (Int -> Maybe Placement) -> Placement) -> Point2 -> Point3 -> Placement redMID f wallp lampp = f Nothing defaultLS wallp lampp (const Nothing) -mountLight :: Point2 -> Point3 -> Placement -mountLight = redMID mountLightID +iShape :: Point2 -> Point3 -> Shape +iShape wp (V3 x y z) = thinHighBar z wp (V2 x y) -mountLightLID :: Maybe Color -> LightSource -> Point2 -> Point3 -> (Int -> Maybe Placement) -> Placement -mountLightLID = mountLightOnShape f +lShape :: Point2 -> Point3 -> Shape +lShape wp (V3 x y z) = thinHighBar z wallposUp turnpos + <> thinHighBar z turnpos (V2 x y) where - f wallpos (V3 x y z) = thinHighBar z wallposUp turnpos - <> thinHighBar z turnpos (V2 x y) - where - n = vNormal (wallpos -.- V2 x y) - wallposUp = wallpos +.+ n - turnpos = V2 x y +.+ n + n = vNormal (wp -.- V2 x y) + wallposUp = wp +.+ n + turnpos = V2 x y +.+ n -mountLightL :: Point2 -> Point3 -> Placement -mountLightL = redMID mountLightLID - -mountLightJID :: Maybe Color -> LightSource -> Point2 -> Point3 -> (Int -> Maybe Placement) -> Placement -mountLightJID = mountLightOnShape f +jShape :: Point2 -> Point3 -> Shape +jShape wallpos (V3 x y z) = thinHighBar z wallposUp turn1 + <> thinHighBar z turn1 turn2 + <> thinHighBar z turn2 endpos where - f 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 - turnpos = V2 x y +.+ n - endpos = V2 x y - turn1 = 0.5 *.* (wallposUp +.+ turnpos) - turn2 = 0.5 *.* (turnpos +.+ endpos) + n = vNormal (wallpos -.- V2 x y) + wallposUp = wallpos +.+ n + turnpos = V2 x y +.+ n + endpos = V2 x y + turn1 = 0.5 *.* (wallposUp +.+ turnpos) + turn2 = 0.5 *.* (turnpos +.+ endpos) -mountLightJ :: Point2 -> Point3 -> Placement -mountLightJ = redMID mountLightJID - -mountLightlID :: Maybe Color -> LightSource -> Point2 -> Point3 -> (Int -> Maybe Placement) -> Placement -mountLightlID = mountLightOnShape f +liShape :: Point2 -> Point3 -> Shape +liShape wallpos (V3 x y z) = + thinHighBar z wallposUp turnpos + <> thinHighBar z turnpos (V2 x y) where - f wallpos (V3 x y z) = thinHighBar z wallposUp turnpos - <> thinHighBar z turnpos (V2 x y) - where - n = vNormal (V2 x y -.- wallpos) - wallposUp = wallpos +.+ n - turnpos = V2 x y +.+ n + n = vNormal (V2 x y -.- wallpos) + wallposUp = wallpos +.+ n + turnpos = V2 x y +.+ n -mountLightl :: Point2 -> Point3 -> Placement -mountLightl = redMID mountLightlID - -mountLightAID :: Maybe Color -> LightSource -> Point2 -> Point3 -> (Int -> Maybe Placement) -> Placement -mountLightAID = mountLightOnShape f +aShape :: Point2 -> Point3 -> Shape +aShape wallpos (V3 x y z) = + girder (z+2) 20 10 pout wallpos where - f wallpos (V3 x y z) = girder (z+2) 20 10 pout wallpos - where - pout = V2 x y -.- 2 *.* safeNormalizeV (V2 x y -.- wallpos) + pout = V2 x y -.- 2 *.* safeNormalizeV (V2 x y -.- wallpos) -mountLightA :: Point2 -> Point3 -> Placement -mountLightA = redMID mountLightAID - -mountLightACond :: ((Point2,Float) -> Bool) -> Placement -mountLightACond f = updatePSToLevel 2 (const thePS) $ mountLightA 0 (V3 0 (-40) 40) +vShape :: Point2 -> Point3 -> Shape +vShape wallpos (V3 x y z) = + thinHighBar z wallposUp lxy + <> thinHighBar z wallposDown lxy where - thePS = PSLnk f id Nothing + lxy = V2 x y + n = vNormal (wallpos -.- lxy) + wallposUp = wallpos +.+ n + wallposDown = wallpos -.- n -mountLightVCond :: ((Point2,Float) -> Bool) -> Placement -mountLightVCond f = updatePSToLevel 2 (const thePS) $ mountLightV 0 (V3 0 (-20) 40) - where - thePS = PSLnk f id Nothing +mntLS :: (Point2 -> Point3 -> Shape) -> Point2 -> Point3 -> Placement +mntLS shp = redMID $ mntLSOn shp + +mntLSCond :: (Point2 -> Point3 -> Shape) -> ((Point2,Float) -> Bool) -> Placement +mntLSCond shp cond = updatePSToLevel 2 (const $ PSLnk cond id Nothing) + $ redMID (mntLSOn shp) 0 (V3 0 (-40) 40) + -- note that this perhaps pushes the vshape light out too far mntLight :: Point2 -> Point2 -> Placement -mntLight a b = RandomPlacement $ takeOne - [ mountLightV a (addZ 50 b) - , mountLight a (addZ 50 b) - , mountLightL a (addZ 50 b) - , mountLightJ a (addZ 50 b) - , mountLightl a (addZ 50 b) - ] +mntLight a b = RandomPlacement $ do + shp <- takeOne [vShape,iShape,lShape,jShape,liShape] + return $ redMID (mntLSOn shp) a (addZ 50 b) mntLightLnkCond :: ((Point2,Float) -> Bool) -> Placement -mntLightLnkCond f = RandomPlacement $ takeOne [mountLightVCond f,mountLightACond f] - -mountLightVID :: Maybe Color -> LightSource -> Point2 -> Point3 -> (Int -> Maybe Placement) -> Placement -mountLightVID = mountLightOnShape f - where - f wallpos (V3 x y z) = thinHighBar z wallposUp lxy - <> thinHighBar z wallposDown lxy - where - lxy = V2 x y - n = vNormal (wallpos -.- lxy) - wallposUp = wallpos +.+ n - wallposDown = wallpos -.- n - -mountLightV :: Point2 -> Point3 -> Placement -mountLightV = redMID mountLightVID +mntLightLnkCond f = RandomPlacement $ do + shp <- takeOne [vShape,iShape,lShape,jShape,liShape] + return $ mntLSCond shp f spanColLightI :: Point3 -> Float -> Point2 -> Point2 -> Placement spanColLightI col h a b = ps0j (PutLS $ colorLightAt col (V3 x y (h-5)) 0) diff --git a/src/Dodge/Placements/Spot.hs b/src/Dodge/Placements/Spot.hs index 8a99cefb5..822172f2f 100644 --- a/src/Dodge/Placements/Spot.hs +++ b/src/Dodge/Placements/Spot.hs @@ -9,6 +9,8 @@ import Dodge.LevelGen.Data setPS :: PlacementSpot -> Placement -> Placement setPS = updatePS . const +-- TODO remove this, use previous placement spots in continued placements +-- instead updatePSToLevel :: Int -> (PlacementSpot -> PlacementSpot) -> Placement -> Placement updatePSToLevel 0 _ plmnt = plmnt updatePSToLevel i f plmnt = case plmnt of diff --git a/src/Dodge/Room/Airlock.hs b/src/Dodge/Room/Airlock.hs index d6a43936b..4701cde5c 100644 --- a/src/Dodge/Room/Airlock.hs +++ b/src/Dodge/Room/Airlock.hs @@ -92,8 +92,8 @@ airlockZ = defaultRoom col = dim $ dim $ bright red outDoorps = (V2 0 0 ,) <$> arcStepwise 3 (pi/2) (V2 0 0) (V2 0 (-61)) inDoorps = (V2 0 0 ,) <$> arcStepwise 3 (pi/2) (V2 0 0) (V2 (-61) 0) - cenlight = mountLightV (V2 90 60) (V3 90 40 50) `addPlmnt` mountLightV (V2 90 60) (V3 90 80 50) - cornlight = mountLightV (V2 0 120) (V3 30 90 50) `addPlmnt` mountLightV (V2 180 120) (V3 150 90 50) + cenlight = mntLS vShape (V2 90 60) (V3 90 40 50) `addPlmnt` mntLS vShape (V2 90 60) (V3 90 80 50) + cornlight = mntLS vShape (V2 0 120) (V3 30 90 50) `addPlmnt` mntLS vShape (V2 180 120) (V3 150 90 50) `addPlmnt` sps0 (PutForeground (thinHighBar 50 (V2 30 90) (V2 150 90))) lighting = RandomPlacement $ takeOne [cenlight,cornlight] @@ -120,7 +120,7 @@ airlock90 = defaultRoom , _rmPmnts = [pContID (PS (V2 120 120) (3 * pi/4)) (PutButton $ makeSwitch col red id id) $ \btid -> jsps (V2 5 5) 0 $ PutDoor col (cond btid) pss - ,mountLightV (V2 20 20) (V3 70 70 50) + ,mntLS vShape (V2 20 20) (V3 70 70 50) ] , _rmBound = [map toV2 [ (10,10) @@ -149,7 +149,7 @@ airlockCrystal = defaultRoom [pContID (PS (V2 145 70) (pi/2)) ( PutButton $ makeSwitch col red id id) $ \btid -> jsps0 $ PutDoor col (cond btid) pss , crystalLine (V2 0 70) (V2 40 70) - , mountLightV (V2 150 70) (V3 110 70 70) + , mntLS vShape (V2 150 70) (V3 110 70 70) ] , _rmBound = [ ] diff --git a/src/Dodge/Room/Boss.hs b/src/Dodge/Room/Boss.hs index bd9cd550b..473f25bf6 100644 --- a/src/Dodge/Room/Boss.hs +++ b/src/Dodge/Room/Boss.hs @@ -119,7 +119,7 @@ roomShuriken x y = { _rmPolys = ps , _rmLinks = [(V2 (x-1) (y-20),negate $ pi/2)] , _rmPath = [] - , _rmPmnts = [mountLight (V2 x x) (V3 (x-20) x 70)] + , _rmPmnts = [mntLS iShape (V2 x x) (V3 (x-20) x 70)] , _rmBound = ps } in foldr1 combineRooms $ map (\r -> shiftRoomBy (V2 0 0, r) corner) [0,pi/2,pi,3*pi/2] @@ -143,7 +143,7 @@ roomTwistCross x y z = { _rmPolys = ps , _rmLinks = [(V2 z (y-20), pi/2)] , _rmPath = [] - , _rmPmnts = [mountLight (V2 x x) (V3 (x-20) (x-20) 70)] + , _rmPmnts = [mntLS iShape (V2 x x) (V3 (x-20) (x-20) 70)] , _rmBound = ps } in foldr1 combineRooms $ map (\r -> shiftRoomBy (V2 0 0, r) corner) [0,pi/2,pi,3*pi/2] diff --git a/src/Dodge/Room/Procedural.hs b/src/Dodge/Room/Procedural.hs index ef77436c7..91d7b75a4 100644 --- a/src/Dodge/Room/Procedural.hs +++ b/src/Dodge/Room/Procedural.hs @@ -100,16 +100,16 @@ Add a light and a 'PutNothing' placement. -} quarterRoomFlat :: RandomGen g => Float -> State g Room quarterRoomFlat w = do b <- takeOne - [ [ mountLightV (V2 0 w) (V3 0 (w-20) 70) - , mountLight (V2 (w-20) w) (V3 (w-20) (w-20) 70) + [ [ mntLS vShape (V2 0 w) (V3 0 (w-20) 70) + , mntLS iShape (V2 (w-20) w) (V3 (w-20) (w-20) 70) , sPS (V2 (w-20) (w-20)) pi PutNothing , blockLine (V2 (w/2) (w/2)) (V2 (w/2) w) ] - , [ mountLight (V2 (w-20) w) (V3 (w-20) (w-20) 70) + , [ mntLS iShape (V2 (w-20) w) (V3 (w-20) (w-20) 70) , sPS (V2 (w-20) (w-20)) pi PutNothing , blockLine (V2 (w/2) (w/2)) (V2 (negate $ w/2) (w/2)) ] - , [ mountLight (V2 (w-20) w) (V3 (w-20) (w-20) 70) + , [ mntLS iShape (V2 (w-20) w) (V3 (w-20) (w-20) 70) , sPS (V2 (w-20) (w-20)) pi PutNothing , blockLine (V2 (w/2) (w/2)) (V2 0 (w/2)) , blockLine (V2 (-29) w) (V2 0 (w/2)) @@ -133,17 +133,17 @@ quarterRoomFlat w = do fourthCornerWall :: RandomGen g => Float -> State g Room fourthCornerWall w = do b <- takeOne - [ [ mountLightV (V2 0 (2*w-20)) (V3 0 (2*w-40) 70) + [ [ mntLS vShape (V2 0 (2*w-20)) (V3 0 (2*w-40) 70) , blockLine (V2 (w/2) (w/2)) (V2 0 w) , blockLine (V2 (negate $ w/2) (w/2)) (V2 0 w) , sPS (V2 20 (2*w-40)) pi PutNothing ] - , [ mountLightV (V2 0 (2*w-20)) (V3 0 (2*w-40) 70) + , [ mntLS vShape (V2 0 (2*w-20)) (V3 0 (2*w-40) 70) , blockLine (V2 (w/2) (w/2)) (V2 0 w) , blockLine (V2 (negate w) w ) (V2 0 w) , sPS (V2 20 (2*w-40)) pi PutNothing ] - , [ mountLight (V2 (0.7*w) (1.3*w)) (V3 (0.7*w-20) (1.3*w-20) 70) + , [ mntLS iShape (V2 (0.7*w) (1.3*w)) (V3 (0.7*w-20) (1.3*w-20) 70) , blockLine (V2 (w/2) (w/2)) (V2 0 w) , blockLine (V2 0 w) (V2 0 (w*2)) , sPS (V2 20 (2*w-40)) pi PutNothing @@ -228,7 +228,7 @@ centerVaultRoom w h d = do ,sps0 $ PutWall (rectNSEW (-d) (30 - d) (-d) (30 - d)) defaultWall ,sps0 $ PutForeground $ girder 70 10 10 (V2 (d-11) (-d)) (V2 (d-11) (-h)) ] - ++ map (\a -> mountLightV (rotateV a $ V2 0 d) (rotate3z a $ V3 0 (d+30) 70)) + ++ map (\a -> mntLS vShape (rotateV a $ V2 0 d) (rotate3z a $ V3 0 (d+30) 70)) [0,0.5*pi,pi,1.5*pi] ++ concatMap (\r -> map (shiftPlacement (V2 0 0,r)) theDoor) [0,pi/2,pi,3*pi/2] diff --git a/src/Dodge/Room/RoadBlock.hs b/src/Dodge/Room/RoadBlock.hs index cfc10e234..6d634cff9 100644 --- a/src/Dodge/Room/RoadBlock.hs +++ b/src/Dodge/Room/RoadBlock.hs @@ -83,7 +83,7 @@ lasTunnel = defaultRoom , _rmLinks = [(V2 20 190,1.5* pi),(V2 0 20,0.5* pi)] , _rmPmnts = [putLasTurret & plSpot .~ PS (V2 10 240) (1.5*pi) , lowWall (rectNSEW 65 40 0 25) - , mountLightV (V2 50 10) (V3 40 20 50) + , mntLS vShape (V2 50 10) (V3 40 20 50) ] } where diff --git a/src/Dodge/Room/Room.hs b/src/Dodge/Room/Room.hs index 72276c1d3..9194a2c8b 100644 --- a/src/Dodge/Room/Room.hs +++ b/src/Dodge/Room/Room.hs @@ -55,8 +55,8 @@ roomPillars :: Room roomPillars = over rmLinks init $ set rmPmnts plmnts $ roomRect 240 240 2 2 where plmnts = spanLightI (V2 120 24) (V2 120 216) - : mountLightV (V2 12 12) (V3 25 25 70) - : mountLightV (V2 228 228) (V3 215 215 70) + : mntLS vShape (V2 12 12) (V3 25 25 70) + : mntLS vShape (V2 228 228) (V3 215 215 70) : sps0 (PutForeground $ thinHighBar 75 (V2 26 25) (V2 120 25)) : sps0 (PutForeground $ thinHighBar 75 (V2 214 215) (V2 120 215)) : g 180 150 90 60 @@ -85,7 +85,7 @@ glassLesson = do ,sPS (V2 50 100) 0 $ PutCrit miniGunCrit ,RandomPlacement $ takeOne [ spanLightI (V2 160 0) (V2 160 220) - , mountLightV (V2 180 200) (V3 160 180 50) + , mntLS vShape (V2 180 200) (V3 160 180 50) ] ] topplmnts = @@ -94,7 +94,7 @@ glassLesson = do --,sPS (V2 50 50) 0 putLamp ,RandomPlacement $ takeOne [ spanLightI (V2 160 (-20)) (V2 160 220) - , mountLightV (V2 180 200) (V3 160 180 50) + , mntLS vShape (V2 180 200) (V3 160 180 50) ] ] diff --git a/src/Dodge/Room/Start.hs b/src/Dodge/Room/Start.hs index 82a6063b9..6ee0541b4 100644 --- a/src/Dodge/Room/Start.hs +++ b/src/Dodge/Room/Start.hs @@ -1,5 +1,4 @@ -module Dodge.Room.Start - where +module Dodge.Room.Start where import Dodge.Room.Data import Dodge.Room.Door import Dodge.Room.Link @@ -33,7 +32,7 @@ startRoom = do $ roomRectAutoLinks w h & rmPmnts %~ ( [ fground - , mountLightJ (V2 0 (h/3)) (V3 40 (h/3) 70) + , mntLS jShape (V2 0 (h/3)) (V3 40 (h/3) 70) , tankSquareEmboss4 (dim orange) 50 (h-60) , tankSquare (dim orange) 50 50 , tankSquare (dim orange) 50 120 diff --git a/src/Dodge/Room/Treasure.hs b/src/Dodge/Room/Treasure.hs index eb7faf165..010df93e8 100644 --- a/src/Dodge/Room/Treasure.hs +++ b/src/Dodge/Room/Treasure.hs @@ -32,7 +32,7 @@ triLootRoom w h = pure $ defaultRoom [sPS (V2 (15-w) 15 ) 0 $ PutID 0 ,sPS (V2 (w-15) 15 ) pi $ PutID 0 ,sPS (V2 0 (h-35)) 0 $ PutID 2 - ,mountLightV (V2 0 (h-20)) (V3 0 (h-80) 70) + ,mntLS vShape (V2 0 (h-20)) (V3 0 (h-80) 70) ,sPS (V2 0 ( -60)) 0 putLamp ] , _rmBound = [tri , base]