From c88f88004d1247851d404ca08471f05401c5dc63 Mon Sep 17 00:00:00 2001 From: justin Date: Thu, 30 Sep 2021 15:35:35 +0100 Subject: [PATCH] Fix wall bug, refactor placements --- src/Dodge/Base.hs | 2 +- src/Dodge/Initialisation.hs | 23 +++++------------------ src/Dodge/Layout.hs | 1 - src/Dodge/LevelGen.hs | 22 +++++++--------------- src/Dodge/LevelGen/Block.hs | 1 - src/Dodge/LevelGen/Data.hs | 20 ++------------------ src/Dodge/LevelGen/MoveDoor.hs | 1 - src/Dodge/LightSources/Fitting.hs | 7 +------ src/Dodge/LightSources/Lamp.hs | 7 +++---- src/Dodge/Placement.hs | 10 ++++++++++ src/Dodge/Render/Picture.hs | 1 + src/Dodge/Room/Airlock.hs | 6 +++--- src/Dodge/Room/LongDoor.hs | 15 ++++++--------- src/Dodge/Room/Procedural.hs | 3 ++- src/Dodge/WorldEvent/ThingsHit.hs | 2 +- src/Dodge/Zone.hs | 9 ++++++++- src/Geometry/Vector3D.hs | 4 ++++ 17 files changed, 54 insertions(+), 80 deletions(-) create mode 100644 src/Dodge/Placement.hs diff --git a/src/Dodge/Base.hs b/src/Dodge/Base.hs index bc2c913a6..dfdeb702b 100644 --- a/src/Dodge/Base.hs +++ b/src/Dodge/Base.hs @@ -7,7 +7,7 @@ module Dodge.Base where import Dodge.Data import Dodge.Zone -import Dodge.Zone.Data +--import Dodge.Zone.Data import Dodge.Base.Window import Geometry --import Picture diff --git a/src/Dodge/Initialisation.hs b/src/Dodge/Initialisation.hs index 672a7b765..9e0bb2528 100644 --- a/src/Dodge/Initialisation.hs +++ b/src/Dodge/Initialisation.hs @@ -23,7 +23,7 @@ import System.Random import qualified Data.Set as S import qualified Data.IntMap.Strict as IM import qualified Data.Map as M -import Data.Maybe +--import Data.Maybe --import Control.Lens --import Data.List (partition) --import Data.List (sortOn) @@ -61,24 +61,11 @@ initialWorld = defaultWorld , _worldState = M.empty } testStringInit :: World -> [String] ---testStringInit _ = [] ---testStringInit w = --- [show $ _worldMinX w --- ,show $ _worldMaxX w --- ,show $ _worldMinY w --- ,show $ _worldMaxY w --- ] ---testStringInit = mapMaybe f . IM.elems . wallsDoubleScreen +testStringInit _ = [] +--testStringInit = mapMaybe f . IM.elems . flattenIMIMIM . _znObjects . _wallsZone -- where --- f (dr@Door{}) = Just . show $ _wlLine dr --- f _ = Nothing ---testStringInit = map show . filter ((== col) . snd) . fst . wallsAndWindows --- where --- col = dim $ dim $ bright red -testStringInit = mapMaybe f . IM.elems . _walls - where - f dr | _wlColor dr == V4 0 1 0 1 = Just . show $ _wlLine dr - | otherwise = Nothing +-- f dr | _wlColor dr == V4 0 1 0 1 = Just . show $ _wlLine dr +-- | otherwise = Nothing --testStringInit _ = [] --testStringInit w = [show . length $ newSounds w] --testStringInit w = (show . _crPos $ _creatures w IM.! 0) diff --git a/src/Dodge/Layout.hs b/src/Dodge/Layout.hs index 5c4edcf2e..0e23d68b5 100644 --- a/src/Dodge/Layout.hs +++ b/src/Dodge/Layout.hs @@ -7,7 +7,6 @@ import Dodge.LevelGen.StaticWalls --import Dodge.LevelGen.Data import Dodge.Base import Dodge.Zone -import Dodge.Zone.Data import Dodge.GameRoom import Dodge.Bounds --import Dodge.RandomHelp diff --git a/src/Dodge/LevelGen.hs b/src/Dodge/LevelGen.hs index 31a63828c..4dcef9419 100644 --- a/src/Dodge/LevelGen.hs +++ b/src/Dodge/LevelGen.hs @@ -123,18 +123,8 @@ placeProp placeProp pr p a w = (i, w & props %~ addProp) where i = IM.newKey $ _props w - addProp prs = IM.insert (IM.newKey prs) (over pjRot (+a) pr {_pjPos = p, _pjID = IM.newKey prs}) prs - -placePropID - :: Prop - -> Point2 - -> Float -- ^ Rotation - -> World - -> (World,Int) -placePropID pr p a w = (w & props %~ addProp , k) - where - k = IM.newKey (_props w) - addProp prs = IM.insert (IM.newKey prs) (over pjRot (+a) pr {_pjPos = p, _pjID = IM.newKey prs}) prs + addProp prs = IM.insert i (f pr) prs + f = (pjRot +~ a) . (pjPos %~ ( (p +.+) . (rotateV a) )) . (pjID .~ i) placeBt :: Button @@ -142,10 +132,12 @@ placeBt -> Float -- ^ Rotation -> World -> (Int, World) -placeBt bt p rot w = (i , over buttons addBT w) +placeBt bt p a w = (i , over buttons addBT w) where i = IM.newKey $ _buttons w - addBT bts = IM.insert (IM.newKey bts) (bt {_btPos = p, _btRot = rot, _btID = IM.newKey bts}) bts + addBT xs = IM.insert i (f bt) xs + f = (btRot +~ a) . (btPos %~ ( (p +.+) . (rotateV a) )) . (btID .~ i) + --addBT bts = IM.insert (IM.newKey bts) (bt {_btPos = p, _btRot = rot, _btID = IM.newKey bts}) bts {- Creates a floor item at a given point. Assigns an id correctly. -} placeFlIt @@ -197,7 +189,7 @@ placeLS :: LightSource -> Point3 -> Float -> World -> (Int,World) placeLS ls (V3 x y z) rot w = (i, over lightSources addLS w) where i = IM.newKey $ _lightSources w - startPos = _lsPos ls + startPos = onXY (rotateV rot) $ _lsPos ls addLS lss = IM.insert (IM.newKey lss) (ls {_lsPos = V3 x y z +.+.+ startPos,_lsDir = rot,_lsID = IM.newKey lss}) diff --git a/src/Dodge/LevelGen/Block.hs b/src/Dodge/LevelGen/Block.hs index 6c20fd121..2f2b5f5f6 100644 --- a/src/Dodge/LevelGen/Block.hs +++ b/src/Dodge/LevelGen/Block.hs @@ -4,7 +4,6 @@ import Dodge.Data import Dodge.Data.SoundOrigin import Dodge.Base import Dodge.Zone -import Dodge.Zone.Data import Dodge.SoundLogic import Dodge.SoundLogic.LoadSound import Dodge.WorldEvent.Sound diff --git a/src/Dodge/LevelGen/Data.hs b/src/Dodge/LevelGen/Data.hs index a237ab317..0bf066055 100644 --- a/src/Dodge/LevelGen/Data.hs +++ b/src/Dodge/LevelGen/Data.hs @@ -1,23 +1,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE StrictData #-} module Dodge.LevelGen.Data - ( PSType (..) - , PlacementSpot (..) - , Placement (..) - , sPS - -- lenses - , placementSpot - , psType - , psPos - , psRot - , putID - , pwPoly - , pwWall - , unPutCrit --- , groupPlacementID --- , groupUpdate - , idPlacement - ) where + where import Dodge.Data import Picture import Geometry.Data @@ -44,12 +28,12 @@ data PSType = PutCrit {_unPutCrit :: Creature} | PutForeground Shape | PutNothing | PutID { _putID :: Int} +-- maybe there is a monadic implementation of this? data PlacementSpot = PS { _psPos :: Point2 , _psRot :: Float , _psType :: PSType } --- maybe there is a monadic implementation of this? data Placement = Placement { _placementSpot :: PlacementSpot , _idPlacement :: Int -> Maybe Placement diff --git a/src/Dodge/LevelGen/MoveDoor.hs b/src/Dodge/LevelGen/MoveDoor.hs index 085e0d921..e0e93367f 100644 --- a/src/Dodge/LevelGen/MoveDoor.hs +++ b/src/Dodge/LevelGen/MoveDoor.hs @@ -7,7 +7,6 @@ module Dodge.LevelGen.MoveDoor import Dodge.Data import Dodge.Base import Dodge.Zone -import Dodge.Zone.Data import Geometry import Control.Lens diff --git a/src/Dodge/LightSources/Fitting.hs b/src/Dodge/LightSources/Fitting.hs index 8b07af55f..a8e1ae38c 100644 --- a/src/Dodge/LightSources/Fitting.hs +++ b/src/Dodge/LightSources/Fitting.hs @@ -3,6 +3,7 @@ module Dodge.LightSources.Fitting import Dodge.LightSources.Lamp import Dodge.LevelGen.Data import Dodge.Room.Foreground +import Dodge.Placement import Geometry wallMount :: Point2 -> Point3 -> Placement @@ -66,9 +67,3 @@ wallMountV wallpos lamppos@(V3 x y z) extendAway :: Point2 -> Point2 -> Point2 extendAway p x = p +.+ safeNormalizeV (p -.- x) - -jsps0 :: PSType -> Maybe Placement -jsps0 pst = Just $ sPS (V2 0 0) 0 pst - -place0 :: PSType -> (Int -> Maybe Placement) -> Placement -place0 pst = Placement (PS (V2 0 0) 0 pst) diff --git a/src/Dodge/LightSources/Lamp.hs b/src/Dodge/LightSources/Lamp.hs index dbc46bb38..070b948d5 100644 --- a/src/Dodge/LightSources/Lamp.hs +++ b/src/Dodge/LightSources/Lamp.hs @@ -86,9 +86,9 @@ lampCover h = ShapeProp , _prDraw = drawLampCover h , _prToggle = True } -lampCoverWhen :: (World -> Bool) -> Float -> Prop -lampCoverWhen cond h = ShapeProp - { _pjPos = V2 0 0 +lampCoverWhen :: (World -> Bool) -> Point2 -> Float -> Prop +lampCoverWhen cond pos h = ShapeProp + { _pjPos = pos , _pjID = 0 , _pjRot = 0 , _pjUpdate = setToggle cond `chain` rotateProp 0.15 @@ -138,7 +138,6 @@ drawLampCover h pr | not (_prToggle pr) = mempty , translateSHz 1 . upperPrismPoly 1 $ rectNSEW 3 (-1) 3 2 , translateSHz 2 . upperPrismPoly 1 $ rectNSEW 3 2 3 (-1) , translateSHz 2 . upperPrismPoly 1 $ rectNSEW 3 (-1) 3 2 - --, translateSHz 2.5 . upperPrismPoly 1 $ [V2 5 5,V2 (-4) 5,V2 5 (-4)] , upperPrismPoly 1 [V2 2 2,V2 (-1) 2,V2 2 (-1)] ] , mempty diff --git a/src/Dodge/Placement.hs b/src/Dodge/Placement.hs new file mode 100644 index 000000000..88446487f --- /dev/null +++ b/src/Dodge/Placement.hs @@ -0,0 +1,10 @@ +module Dodge.Placement + where +import Geometry +import Dodge.LevelGen.Data + +jsps0 :: PSType -> Maybe Placement +jsps0 pst = Just $ sPS (V2 0 0) 0 pst + +place0 :: PSType -> (Int -> Maybe Placement) -> Placement +place0 pst = Placement (PS (V2 0 0) 0 pst) diff --git a/src/Dodge/Render/Picture.hs b/src/Dodge/Render/Picture.hs index 5a242e8ab..922629741 100644 --- a/src/Dodge/Render/Picture.hs +++ b/src/Dodge/Render/Picture.hs @@ -238,6 +238,7 @@ wallsAndWindows w where f wl = (_wlLine wl, _wlColor wl) (wins,wls) = partition _wlIsSeeThrough . IM.elems $ wallsDoubleScreen w + --(wins,wls) = partition _wlIsSeeThrough . IM.elems $ wallsOnScreen w wallsToList :: [((Point2,Point2),Point4)] -> [Float] wallsToList = concatMap (\((V2 a b,V2 c d),V4 e f g h) -> [a,b,c,d,e,f,g,h]) diff --git a/src/Dodge/Room/Airlock.hs b/src/Dodge/Room/Airlock.hs index 0695b7c30..818037a24 100644 --- a/src/Dodge/Room/Airlock.hs +++ b/src/Dodge/Room/Airlock.hs @@ -141,11 +141,11 @@ airlockCrystal n = defaultRoom , _rmPS = [sPS (V2 0 0) 0 $ PutDoor col (not . cond) pss ,sPS (V2 145 70) (pi/2) $ PutButton $ makeSwitch col red - (over worldState (M.insert (DoorNumOpen n) True)) (over worldState (M.insert (DoorNumOpen n) False)) + (over worldState (M.insert (DoorNumOpen n) True)) ,crystalLine (V2 0 70) (V2 40 70) - ,sPS (V2 20 40) 0 putLamp - ,sPS (V2 20 100) 0 putLamp + --,sPS (V2 20 40) 0 putLamp + --,sPS (V2 20 100) 0 putLamp ] , _rmBound = [ ] diff --git a/src/Dodge/Room/LongDoor.hs b/src/Dodge/Room/LongDoor.hs index acebb89a2..20668ebdc 100644 --- a/src/Dodge/Room/LongDoor.hs +++ b/src/Dodge/Room/LongDoor.hs @@ -16,6 +16,7 @@ import Dodge.RandomHelp import Dodge.Creature.Inanimate import Dodge.Creature import Dodge.LightSources.Lamp +import Dodge.Placement import Picture import Geometry @@ -41,16 +42,13 @@ twinSlowDoorRoom drid w h x = defaultRoom ] , _rmPath = [] , _rmPS = - [ sPS (V2 0 (h/2)) 0 putLamp - , sPS (V2 25 5) 0 putLamp - , sPS (V2 (negate 25) 5) 0 putLamp - , sPS (V2 0 0) 0 $ PutSingleDoor col cond (V2 x 1) (V2 x h) 1 - , Placement (PS (V2 0 0) 0 $ PutSingleDoor col cond (V2 (-x) 1) (V2 (-x) h) 1) - $ \did -> Just $ Placement (PS (V2 0 (h-1)) 0 $ PutLS (colorLightAt (V3 0.75 0 0) (V3 0 0 lampHeight) 0)) - $ \lsid -> Just $ sPS (V2 0 (h-1)) 0 $ PutProp $ addColorChange lsid did $ lampCoverWhen (drmoving did) lampHeight + [ sPS (V2 0 0) 0 $ PutSingleDoor col cond (V2 x 1) (V2 x h) 1 , sPS (V2 0 (h-5)) pi $ PutButton $ makeSwitch col red (worldState %~ M.insert (DoorNumOpen drid) True ) (worldState %~ M.insert (DoorNumOpen drid) False) + , place0 (PutSingleDoor col cond (V2 (-x) 1) (V2 (-x) h) 1) + $ \did -> Just $ place0 (PutLS (colorLightAt (V3 0.75 0 0) (V3 0 (h-1) lampHeight) 0)) + $ \lsid -> jsps0 $ PutProp $ addColorChange lsid did $ lampCoverWhen (drmoving did) (V2 0 (h-1)) lampHeight ] , _rmBound = ps , _rmName = "twinSlowDoorRoom" @@ -68,8 +66,7 @@ twinSlowDoorRoom drid w h x = defaultRoom ,rectNSWE 20 (-h) (negate x) x ] cond w' = or $ M.lookup (DoorNumOpen drid) (_worldState w') - --col = dim $ dim $ bright red - col = V4 0 1 0 1 + col = dim $ dim $ bright red twinSlowDoorChasers :: RandomGen g diff --git a/src/Dodge/Room/Procedural.hs b/src/Dodge/Room/Procedural.hs index 1db65f001..d93eb7d79 100644 --- a/src/Dodge/Room/Procedural.hs +++ b/src/Dodge/Room/Procedural.hs @@ -21,6 +21,7 @@ import Dodge.Item.Weapon import Dodge.RandomHelp import Dodge.LevelGen import Dodge.LevelGen.Data +import Dodge.LightSources.Fitting import Dodge.Creature --import Dodge.Default import Geometry @@ -49,7 +50,7 @@ roomRect x y xn yn = defaultRoom { _rmPolys = [rectNSWE y 0 0 x ] , _rmLinks = lnks , _rmPath = concatMap doublePair pth - , _rmPS = [sPS (V2 (x/2) (y/2)) 0 putLamp] + , _rmPS = [wallMountL (V2 (x/2) 0) (V3 (x/2) 40 50)] , _rmBound = [rectNSWE (y+5) (-5) (-5) (x+5)] , _rmFloor = [Tile { _tilePoly = rectNSWE y 0 0 x diff --git a/src/Dodge/WorldEvent/ThingsHit.hs b/src/Dodge/WorldEvent/ThingsHit.hs index 33846685e..22c4481ea 100644 --- a/src/Dodge/WorldEvent/ThingsHit.hs +++ b/src/Dodge/WorldEvent/ThingsHit.hs @@ -11,7 +11,7 @@ module Dodge.WorldEvent.ThingsHit import Dodge.Data import Dodge.Base import Dodge.Zone -import Dodge.Zone.Data +--import Dodge.Zone.Data import Geometry import qualified Data.IntMap.Strict as IM diff --git a/src/Dodge/Zone.hs b/src/Dodge/Zone.hs index 0afbadaca..33d0de319 100644 --- a/src/Dodge/Zone.hs +++ b/src/Dodge/Zone.hs @@ -16,6 +16,8 @@ module Dodge.Zone , cloudsNearPoint , wallsNearZones , zoneOfSight + , flattenIMIMIM + , module Dodge.Zone.Data ) where import Dodge.Data @@ -87,7 +89,9 @@ zoneOfSight w = wallsDoubleScreen :: World -> IM.IntMap Wall wallsDoubleScreen w - = foldl' (flip $ IM.union . \i -> innerFold (f i (_znObjects $ _wallsZone w))) IM.empty xs + -- = foldl' (flip $ IM.union . \i -> innerFold (f i (_znObjects $ _wallsZone w))) IM.empty xs + -- for some reason (TODO diagnose) the foldl' version causes errors + = foldr (IM.union . \i -> innerFold (f i (_znObjects $ _wallsZone w))) IM.empty xs where innerFold m = foldl' (flip $ IM.union . \ j -> f j m) IM.empty ys f i m = case IM.lookup i m of @@ -168,3 +172,6 @@ wallsNearPoint p w = IM.unions [f b $ f a $ _znObjects $ _wallsZone w | a<-[x-1 f i m = case IM.lookup i m of Just val -> val _ -> IM.empty + +flattenIMIMIM :: IM.IntMap (IM.IntMap (IM.IntMap a)) -> IM.IntMap a +flattenIMIMIM = IM.unions . fmap IM.unions diff --git a/src/Geometry/Vector3D.hs b/src/Geometry/Vector3D.hs index a141db846..1c631b108 100644 --- a/src/Geometry/Vector3D.hs +++ b/src/Geometry/Vector3D.hs @@ -104,3 +104,7 @@ projV3 projV3 = undefined +onXY :: (Point2 -> Point2) -> Point3 -> Point3 +onXY f (V3 x y z) = V3 x' y' z + where + V2 x' y' = f (V2 x y)