justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Fix wall bug, refactor placements

Browse Source
This commit is contained in:
justin
2021-09-30 15:35:35 +01:00
parent eb393708c4
commit c88f88004d
17 changed files with 54 additions and 80 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Base.hs
+1 -1
View File
@@ -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
src/Dodge/Initialisation.hs
+5 -18
View File
@@ -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)
src/Dodge/Layout.hs
-1
View File
@@ -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
src/Dodge/LevelGen.hs
+7 -15
View File
@@ -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})
src/Dodge/LevelGen/Block.hs
-1
View File
@@ -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
src/Dodge/LevelGen/Data.hs
+2 -18
View File
@@ -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
src/Dodge/LevelGen/MoveDoor.hs
-1
View File
@@ -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
src/Dodge/LightSources/Fitting.hs
+1 -6
View File
@@ -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)
src/Dodge/LightSources/Lamp.hs
+3 -4
View File
@@ -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
src/Dodge/Placement.hs
+10
View File
@@ -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)
src/Dodge/Render/Picture.hs
+1
View File
@@ -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])
src/Dodge/Room/Airlock.hs
+3 -3
View File
@@ -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 =
[ ]
src/Dodge/Room/LongDoor.hs
+6 -9
View File
@@ -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
src/Dodge/Room/Procedural.hs
+2 -1
View File
@@ -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
src/Dodge/WorldEvent/ThingsHit.hs
+1 -1
View File
@@ -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
src/Dodge/Zone.hs
+8 -1
View File
@@ -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
src/Geometry/Vector3D.hs
+4
View File
@@ -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)