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

Move towards more usable placements

Browse Source
This commit is contained in:
justin
2021-11-13 00:04:50 +00:00
parent 67e164c830
commit b243479759
13 changed files with 167 additions and 208 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Default/Room.hs
+2 -3
View File
@@ -3,7 +3,6 @@ module Dodge.Default.Room
import Geometry.Data import Geometry.Data
import Dodge.Room.Data import Dodge.Room.Data
import qualified Data.IntMap.Strict as IM
defaultRoom :: Room defaultRoom :: Room
defaultRoom = Room defaultRoom = Room
{ _rmPolys = [] { _rmPolys = []
@@ -11,8 +10,8 @@ defaultRoom = Room
, _rmPos = [] , _rmPos = []
, _rmPath = [] , _rmPath = []
, _rmPmnts = [] , _rmPmnts = []
, _rmTriggerPmnts = IM.empty , _rmPartialPmnt = Nothing
, _rmTriggers = IM.empty , _rmExtendedPmnt = Nothing
, _rmBound = [] , _rmBound = []
, _rmFloor = [] , _rmFloor = []
, _rmName = "defaultRoom" , _rmName = "defaultRoom"
src/Dodge/Layout.hs
+61 -64
View File
@@ -1,34 +1,29 @@
--{-# LANGUAGE TupleSections #-} --{-# LANGUAGE TupleSections #-}
module Dodge.Layout module Dodge.Layout
where ( generateLevelFromRoomList
, doPartialPlacements
, doExtendedPlacements
) where
import Dodge.Data import Dodge.Data
import Dodge.LevelGen import Dodge.LevelGen
import Dodge.LevelGen.Data
import Dodge.LevelGen.StaticWalls import Dodge.LevelGen.StaticWalls
import Dodge.LevelGen.Pathing import Dodge.LevelGen.Pathing
import Dodge.Wall.Zone import Dodge.Wall.Zone
import Dodge.Zone
import Dodge.GameRoom import Dodge.GameRoom
import Dodge.Bounds import Dodge.Bounds
import Dodge.Layout.Tree.Polymorphic (applyToRoot)
import Dodge.Room.Data import Dodge.Room.Data
import Dodge.Room.AddTile import Dodge.Room.AddTile
import Dodge.Default.Wall import Dodge.Default.Wall
import Geometry import Geometry
--import Geometry.Data --import Geometry.Data
import Dodge.Room.Link
import qualified IntMapHelp as IM import qualified IntMapHelp as IM
--import Dodge.Debug.LinkDecoration --import Dodge.Debug.LinkDecoration
import Picture.Data
import Tile import Tile
import Polyhedra
import Polyhedra.Data
import Data.List (nubBy) import Data.List (nubBy)
--import Control.Monad.State --import Control.Monad.State
import Control.Lens import Control.Lens
import System.Random import System.Random
import Data.Tree
--import Data.Graph.Inductive.Graph (labNodes) --import Data.Graph.Inductive.Graph (labNodes)
--import qualified Data.Map as M --import qualified Data.Map as M
import Data.Foldable import Data.Foldable
@@ -52,13 +47,29 @@ generateLevelFromRoomList gr w
rs = zipWith addTile zs gr rs = zipWith addTile zs gr
zs = map fromIntegral $ randomRs (0,63::Int) $ _randGen w zs = map fromIntegral $ randomRs (0,63::Int) $ _randGen w
doPartialPlacements :: [Room] -> (IM.IntMap Int,World) -> World
doPartialPlacements rms (im,w) = foldr (doPartialPlacement im) w rms
doPartialPlacement :: IM.IntMap Int -> Room -> World -> World
doPartialPlacement im rm w = case _rmPartialPmnt rm of
Nothing -> w
Just fi -> case _rmTakeFrom rm of
Nothing -> w
Just i -> fst $ placeSpot (w,rm) (fi (im IM.! i))
doExtendedPlacements :: [Room] -> World -> (IM.IntMap Int, World)
doExtendedPlacements rms w = foldr doExtendedPlacement (IM.empty,w) rms
doExtendedPlacement :: Room -> (IM.IntMap Int, World) -> (IM.IntMap Int, World)
doExtendedPlacement rm (im,w) = case _rmExtendedPmnt rm of
Nothing -> (im,w)
Just _ -> case _rmLabel rm of
Nothing -> (im,w)
Just _ -> undefined
doRoomPlacements :: World -> Room -> World doRoomPlacements :: World -> Room -> World
doRoomPlacements w rm = fst $ foldl' placeSpot (w,rm) $ _rmPmnts rm doRoomPlacements w rm = fst $ foldl' placeSpot (w,rm) $ _rmPmnts rm
updatePSLnkUsing :: (Point2,Float) -> PlacementSpot -> PlacementSpot
updatePSLnkUsing pf PSLnk{_psLinkShift=f} = uncurry PS $ f pf
updatePSLnkUsing _ ps = ps
setupWorldBounds :: World -> World setupWorldBounds :: World -> World
setupWorldBounds w = w setupWorldBounds w = w
& worldBounds . bdMinX .~ f minx & worldBounds . bdMinX .~ f minx
@@ -75,8 +86,8 @@ setupWorldBounds w = w
<*> L.premap sndV2 L.maximum <*> L.premap sndV2 L.maximum
) ps ) ps
polyhedrasToEdges :: [Polyhedra] -> [Point3] --polyhedrasToEdges :: [Polyhedra] -> [Point3]
polyhedrasToEdges = concatMap tflat4 . concatMap polyToEdges --polyhedrasToEdges = concatMap tflat4 . concatMap polyToEdges
initWallZoning :: World -> World initWallZoning :: World -> World
initWallZoning w = foldl' (flip insertWallInZones) (w & wallsZone . znObjects .~ IM.empty) (_walls w) initWallZoning w = foldl' (flip insertWallInZones) (w & wallsZone . znObjects .~ IM.empty) (_walls w)
@@ -84,22 +95,8 @@ initWallZoning w = foldl' (flip insertWallInZones) (w & wallsZone . znObjects .~
-- where -- where
-- wallInZone wl = flip (foldl' (flip $ \(a,b) -> insertIMInZone a b (_wlID wl) wl)) (zoneOfWall wl) -- wallInZone wl = flip (foldl' (flip $ \(a,b) -> insertIMInZone a b (_wlID wl) wl)) (zoneOfWall wl)
makePath :: Tree Room -> [(Point2,Point2)] --makePath :: Tree Room -> [(Point2,Point2)]
makePath = concatMap _rmPath . flatten --makePath = concatMap _rmPath . flatten
-- consider nubbing walls after dividing them
wallsFromTree :: Tree Room -> IM.IntMap Wall
wallsFromTree t =
-- createInnerWalls
divideWalls
. assignKeys
. removeInverseWalls
. foldl' (flip cutWalls) [] -- map (map (g . roundPoint2))
-- . map (map roundPoint2)
$ concatMap _rmPolys (flatten t)
where
assignKeys = IM.fromList . zip [0..] . zipWith f [0..]
f i (x,y) = defaultWall {_wlLine = (x,y) , _wlID = i}
wallsFromRooms :: [Room] -> IM.IntMap Wall wallsFromRooms :: [Room] -> IM.IntMap Wall
wallsFromRooms = wallsFromRooms =
@@ -132,40 +129,40 @@ gameRoomsFromRooms = map f
floorsFromRooms :: [Room] -> [(Point3,Point3)] floorsFromRooms :: [Room] -> [(Point3,Point3)]
floorsFromRooms = concatMap (concatMap tToRender . _rmFloor) floorsFromRooms = concatMap (concatMap tToRender . _rmFloor)
divideWall :: Wall -> [Wall] --divideWall :: Wall -> [Wall]
divideWall wl --divideWall wl
= let (a,b) = _wlLine wl -- = let (a,b) = _wlLine wl
ps = divideLine (zoneSize * 2) a b -- ps = divideLine (zoneSize * 2) a b
in zipWith (\ x y -> wl & wlLine .~ (x,y) ) (init ps) (tail ps) -- in zipWith (\ x y -> wl & wlLine .~ (x,y) ) (init ps) (tail ps)
divideWallIn :: Wall -> IM.IntMap Wall -> IM.IntMap Wall --divideWallIn :: Wall -> IM.IntMap Wall -> IM.IntMap Wall
divideWallIn wl wls = --divideWallIn wl wls =
let (wl':newWls) = divideWall wl -- let (wl':newWls) = divideWall wl
k = IM.newKey wls -- k = IM.newKey wls
newWls' = zipWith (\i w -> w {_wlID = i}) [k..] newWls -- newWls' = zipWith (\i w -> w {_wlID = i}) [k..] newWls
in foldl' (flip $ \w -> IM.insert (_wlID w) w) wls (wl':newWls') -- in foldl' (flip $ \w -> IM.insert (_wlID w) w) wls (wl':newWls')
--
--divideWalls :: IM.IntMap Wall -> IM.IntMap Wall
--divideWalls wls = foldl' (flip divideWallIn) wls wls
divideWalls :: IM.IntMap Wall -> IM.IntMap Wall --insertInZone :: Int -> Int -> a -> IM.IntMap (IM.IntMap a) -> IM.IntMap (IM.IntMap a)
divideWalls wls = foldl' (flip divideWallIn) wls wls --insertInZone x y obj = IM.insertWith f x $ IM.singleton y obj
-- where f _ = IM.insert y obj
insertInZone :: Int -> Int -> a -> IM.IntMap (IM.IntMap a) -> IM.IntMap (IM.IntMap a) --shiftRoomTree :: Tree Room -> Tree Room
insertInZone x y obj = IM.insertWith f x $ IM.singleton y obj --shiftRoomTree (Node t []) = Node t []
where f _ = IM.insert y obj --shiftRoomTree (Node t ts) = Node t
-- $ zipWith (\l -> shiftRoomTree . applyToRoot (shiftRoomToLink l))
-- (_rmLinks t)
-- ts
shiftRoomTree :: Tree Room -> Tree Room --shiftRoomTreeConstruction :: Tree Room -> [Tree Room]
shiftRoomTree (Node t []) = Node t [] --shiftRoomTreeConstruction (Node t []) = [Node t []]
shiftRoomTree (Node t ts) = Node t --shiftRoomTreeConstruction (Node t ts) = (Node t [] :) $ concat $
$ zipWith (\l -> shiftRoomTree . applyToRoot (shiftRoomToLink l)) -- zipWith (\l -> shiftRoomTreeConstruction . applyToRoot (shiftRoomBy l . f))
(_rmLinks t) -- (_rmLinks t)
ts -- ts
-- where
shiftRoomTreeConstruction :: Tree Room -> [Tree Room] -- f r = shiftRoomBy ( V2 0 0 -.- rotateV (pi-a) p , 0) $ shiftRoomBy (V2 0 0,pi-a) r
shiftRoomTreeConstruction (Node t []) = [Node t []] -- where
shiftRoomTreeConstruction (Node t ts) = (Node t [] :) $ concat $ -- (p,a) = last $ _rmLinks r
zipWith (\l -> shiftRoomTreeConstruction . applyToRoot (shiftRoomBy l . f))
(_rmLinks t)
ts
where
f r = shiftRoomBy ( V2 0 0 -.- rotateV (pi-a) p , 0) $ shiftRoomBy (V2 0 0,pi-a) r
where
(p,a) = last $ _rmLinks r
src/Dodge/LevelGen.hs
+60 -97
View File
@@ -23,37 +23,15 @@ import Shape
import qualified IntMapHelp as IM import qualified IntMapHelp as IM
import Color import Color
import System.Random
import Control.Monad.State import Control.Monad.State
import Control.Lens import Control.Lens
import qualified Data.IntSet as IS import qualified Data.IntSet as IS
placeSpotRoomRand :: Room -> Int -> Placement -> World -> (World,Room)
placeSpotRoomRand rm i plmnt w =
let (ps,g) = runState (_rmRandPSs rm !! i) $_randGen w
in placeSpot (w & randGen .~ g,rm) (plmnt & plSpot .~ uncurry PS ps)
placeSpot :: (World,Room) -> Placement -> (World,Room) placeSpot :: (World,Room) -> Placement -> (World,Room)
placeSpot (w,rm) plmnt = case plmnt of placeSpot (w,rm) plmnt = case plmnt of
Placement{_plSpot = PSRoomRand i} -> placeSpotRoomRand rm i plmnt w Placement{_plSpot = PSRoomRand i} -> placeSpotRoomRand rm i plmnt w
-- -> let (ps,g) = runState (_rmRandPSs rm !! i) $_randGen w Placement{_plSpot = PSLnk{}} -> placeSpotUsingLink w rm plmnt
-- in placeSpot (w & randGen .~ g,rm) (plmnt & plSpot .~ uncurry PS ps)
Placement{_plSpot = PSLnk{}} -> case lnks of
((lnki,lnk):_) -> placeSpot (w & randGen .~ g,uselnk lnki) (updatePS (f lnk) plmnt)
[] -> case fallback of
Nothing -> (w,rm)
Just plmnt' -> placeSpot (w,rm) plmnt'
where
uselnk lnki = rm & rmLinks %~ deletei lnki
rps = _plSpot plmnt
fallback = _psFallback rps
test = _psLinkTest rps
(lnks,g) = runState (shuffle $ filter (test . snd) $ zip [0..]
$ map (invShiftLinkBy $ _rmShift rm) $ _rmLinks rm) $ _randGen w
f x (PSLnk t s _)
| t x = uncurry PS $ s x
f _ ps = ps
invShiftLinkBy :: (Point2,Float) -> (Point2,Float) -> (Point2,Float)
invShiftLinkBy (pos,rot) (p,r) = (invShiftPointBy (pos,rot) p, r - rot)
Placement{} -> Placement{} ->
let (i,w') = placeSpotID (shiftPSBy shift (_plSpot plmnt)) (_plType plmnt) w let (i,w') = placeSpotID (shiftPSBy shift (_plSpot plmnt)) (_plType plmnt) w
in maybe (w',rm) (placeSpot (w',rm)) (_plIDCont plmnt i) in maybe (w',rm) (placeSpot (w',rm)) (_plIDCont plmnt i)
@@ -64,15 +42,40 @@ placeSpot (w,rm) plmnt = case plmnt of
where where
shift = _rmShift rm shift = _rmShift rm
placeSpotUsingLink :: World -> Room -> Placement -> (World, Room)
placeSpotUsingLink w rm plmnt = case lnks of
((lnki,lnk):_) -> placeSpot (w & randGen .~ g,uselnk lnki) (updatePS (f lnk) plmnt)
[] -> case fallback of
Nothing -> (w,rm)
Just plmnt' -> placeSpot (w,rm) plmnt'
where
uselnk lnki = rm & rmLinks %~ deletei lnki
rps = _plSpot plmnt
fallback = _psFallback rps
test = _psLinkTest rps
(lnks,g) = runState (shuffle $ filter (test . snd) $ zip [0..]
$ map (invShiftLinkBy $ _rmShift rm) $ _rmLinks rm) $ _randGen w
f x (PSLnk t s _)
| t x = uncurry PS $ s x
f _ ps = ps
invShiftLinkBy :: (Point2,Float) -> (Point2,Float) -> (Point2,Float)
invShiftLinkBy (pos,rot) (p,r) = (invShiftPointBy (pos,rot) p, r - rot)
placeSpotRoomRand :: Room -> Int -> Placement -> World -> (World,Room)
placeSpotRoomRand rm i plmnt w =
let (ps,g) = runState (_rmRandPSs rm !! i) $_randGen w
in placeSpot (w & randGen .~ g,rm) (plmnt & plSpot .~ uncurry PS ps)
deletei :: Int -> [a] -> [a] deletei :: Int -> [a] -> [a]
deletei i xs = take i xs ++ drop (i+1) xs deletei i xs = take i xs ++ drop (i+1) xs
shiftPlacement :: (Point2,Float) -> Placement -> Placement shiftPlacement :: (Point2,Float) -> Placement -> Placement
shiftPlacement shift (Placement ps pt f) = Placement (shiftPSBy shift ps) pt shiftPlacement shift plmnt = case plmnt of
(fmap (fmap $ shiftPlacement shift) f) Placement {} -> plmnt & plSpot %~ shiftPSBy shift
shiftPlacement shift (PlacementUsingPos p f) = PlacementUsingPos (shiftPoint3By shift p) & plIDCont %~ fmap (fmap $ shiftPlacement shift)
(fmap (shiftPlacement shift) f) PlacementUsingPos p f -> PlacementUsingPos (shiftPoint3By shift p)
shiftPlacement shift (RandomPlacement rpl) = RandomPlacement $ fmap (shiftPlacement shift) rpl (fmap (shiftPlacement shift) f)
RandomPlacement rpl -> RandomPlacement $ fmap (shiftPlacement shift) rpl
shiftPSBy :: (Point2,Float) -> PlacementSpot -> PlacementSpot shiftPSBy :: (Point2,Float) -> PlacementSpot -> PlacementSpot
shiftPSBy (pos,rot) ps = ps shiftPSBy (pos,rot) ps = ps
@@ -84,17 +87,14 @@ shiftPSBy (pos,rot) ps = ps
placeSpotID :: PlacementSpot -> PSType -> World -> (Int, World) placeSpotID :: PlacementSpot -> PSType -> World -> (Int, World)
placeSpotID ps pt w = case pt of placeSpotID ps pt w = case pt of
PutTrigger cond -> placeNewInto triggers cond w PutTrigger cond -> placeNewInto triggers cond w
PutProp prop -> placeProp prop p rot w PutProp prop -> plNewUpID props pjID (mvProp p rot prop) w
--PutButton bt -> placeBt bt p rot w PutButton bt -> plNewUpID buttons btID (mvButton p rot bt) w
PutButton bt -> placeNewUpdateID buttons btID (mvButton bt p rot) w PutFlIt itm -> plNewUpID floorItems flItID (createFlIt p rot itm) w
PutFlIt itm -> placeFlIt itm p rot w PutCrit cr -> plNewUpID creatures crID (mvCr p rot cr) w
PutCrit cr -> placeCr cr p rot w
PutMachine col wallpoly mc -> placeMachine col (map doShift wallpoly) mc p rot w PutMachine col wallpoly mc -> placeMachine col (map doShift wallpoly) mc p rot w
PutLS ls -> placeLS ls p' rot w PutLS ls -> plNewUpID lightSources lsID (mvLS p' rot ls) w
PutPressPlate pp -> placePressPlate pp p rot w PutPressPlate pp -> plNewUpID pressPlates ppID (mvPP p rot pp) w
RandPS rgen -> placeSpotID ps evaluatedType (set randGen g w) RandPS rgen -> evaluateRandPS rgen ps w
where
(evaluatedType, g) = runState rgen (_randGen w)
PutDoor col f pss -> placeDoor col f (map (bimap doShift doShift) pss) w PutDoor col f pss -> placeDoor col f (map (bimap doShift doShift) pss) w
PutCoordinate coordp -> placeNewInto coordinates (doShift coordp) w PutCoordinate coordp -> placeNewInto coordinates (doShift coordp) w
PutSlideDoor pathing col f a b spd -> placeSlideDoor pathing col f (doShift a) (doShift b) spd w PutSlideDoor pathing col f a b spd -> placeSlideDoor pathing col f (doShift a) (doShift b) spd w
@@ -112,6 +112,11 @@ placeSpotID ps pt w = case pt of
rot = _psRot ps rot = _psRot ps
doShift = shiftPointBy (p,rot) doShift = shiftPointBy (p,rot)
evaluateRandPS :: State StdGen PSType -> PlacementSpot -> World -> (Int,World)
evaluateRandPS rgen ps w = placeSpotID ps evaluatedType (set randGen g w)
where
(evaluatedType, g) = runState rgen (_randGen w)
placeWallPoly :: [Point2] -> Wall -> World -> World placeWallPoly :: [Point2] -> Wall -> World -> World
placeWallPoly ps wl = rmCrossPaths . over walls (addWalls ps wl) placeWallPoly ps wl = rmCrossPaths . over walls (addWalls ps wl)
where where
@@ -148,71 +153,30 @@ placeNewInto l x w = (i,w & l #%~ IM.insert i x)
i = IM.newKey $ w ^# l i = IM.newKey $ w ^# l
-- | place an new object into an intmap and update its id -- | place an new object into an intmap and update its id
placeNewUpdateID :: ALens' World (IM.IntMap a) plNewUpID :: ALens' World (IM.IntMap a)
-> ALens' a Int -> ALens' a Int
-> a -> a
-> World -> World
-> (Int,World) -> (Int,World)
placeNewUpdateID l li x w = (i,w & l #%~ IM.insert i (x & li #~ i)) plNewUpID l li x w = (i,w & l #%~ IM.insert i (x & li #~ i))
where where
i = IM.newKey $ w ^# l i = IM.newKey $ w ^# l
placeProp mvProp :: Point2 -> Float -> Prop -> Prop
:: Prop mvProp p a = (pjRot +~ a) . (pjPos %~ ( (p +.+) . rotateV a ))
-> Point2
-> Float -- ^ Rotation
-> World
-> (Int, World)
placeProp pr p a w = (i, w & props %~ addProp)
where
i = IM.newKey $ _props w
addProp prs = IM.insert i (f pr) prs
f = (pjRot +~ a) . (pjPos %~ ( (p +.+) . rotateV a )) . (pjID .~ i)
placeBt mvButton :: Point2 -> Float -> Button -> Button
:: Button mvButton p a = (btRot +~ a) . (btPos %~ ( (p +.+) . rotateV a ))
-> Point2
-> Float -- ^ Rotation
-> World
-> (Int, World)
placeBt bt p a w = (i , over buttons addBT w)
where
i = IM.newKey $ _buttons w
addBT = IM.insert i (f bt)
f = (btRot +~ a) . (btPos %~ ( (p +.+) . rotateV a )) . (btID .~ i)
mvButton bt p a = bt & btRot +~ a & btPos %~ ( (p +.+) . rotateV a ) {- Creates a floor item at a given point.-}
createFlIt :: Point2 -> Float -> Item -> FloorItem
createFlIt p rot itm = FlIt { _flItPos = p , _flItRot = rot , _flItID = 0 , _flIt = itm }
{- Creates a floor item at a given point. mvPP :: Point2 -> Float -> PressPlate -> PressPlate
Assigns an id correctly. -} mvPP p rot pp = pp {_ppPos = p,_ppRot = rot}
placeFlIt
:: Item
-> Point2 -- ^ Position
-> Float -- ^ Rotation
-> World
-> (Int, World)
placeFlIt itm p rot w = (i
, w & floorItems %~ IM.insert i FlIt { _flItPos = p , _flItRot = rot , _flItID = i , _flIt = itm }
)
where
i = IM.newKey $ _floorItems w
placePressPlate mvCr :: Point2 -> Float -> Creature -> Creature
:: PressPlate mvCr p rot cr = cr {_crPos = p,_crOldPos = p,_crDir = rot}
-> Point2
-> Float -- ^ Rotation
-> World
-> (Int, World)
placePressPlate pp p rot w = (i , over pressPlates addPP w)
where
i = IM.newKey $ _pressPlates w
addPP pps = IM.insert (IM.newKey pps) (pp {_ppPos = p,_ppRot = rot}) pps
placeCr :: Creature -> Point2 -> Float -> World -> (Int,World)
placeCr crF p rot w = (cid, over creatures addCr w)
where
cid = IM.newKey $ _creatures w
addCr crs = IM.insert cid (crF {_crPos = p,_crOldPos = p,_crDir = rot,_crID = cid}) crs
placeMachine :: Color -> [Point2] -> Machine -> Point2 -> Float -> World -> (Int,World) placeMachine :: Color -> [Point2] -> Machine -> Point2 -> Float -> World -> (Int,World)
placeMachine color wallpoly mc p rot w = (mcid placeMachine color wallpoly mc p rot w = (mcid
@@ -224,6 +188,7 @@ placeMachine color wallpoly mc p rot w = (mcid
wlid = IM.newKey $ _walls w wlid = IM.newKey $ _walls w
wlids = IS.fromList [wlid .. wlid + length wallpoly - 1] wlids = IS.fromList [wlid .. wlid + length wallpoly - 1]
addMc mcs = IM.insert mcid (mc {_mcPos = p,_mcDir = rot,_mcID = mcid, _mcWallIDs = wlids}) mcs addMc mcs = IM.insert mcid (mc {_mcPos = p,_mcDir = rot,_mcID = mcid, _mcWallIDs = wlids}) mcs
-- TODO correctly remove/shift pathfinding lines (removePathsCrossing) -- TODO correctly remove/shift pathfinding lines (removePathsCrossing)
placeMachineWalls :: Color -> [Point2] -> Int -> Int -> IM.IntMap Wall -> IM.IntMap Wall placeMachineWalls :: Color -> [Point2] -> Int -> Int -> IM.IntMap Wall -> IM.IntMap Wall
placeMachineWalls col poly mcid wlid = flip (foldr f) $ zip [wlid..] $ loopPairs poly placeMachineWalls col poly mcid wlid = flip (foldr f) $ zip [wlid..] $ loopPairs poly
@@ -233,9 +198,7 @@ placeMachineWalls col poly mcid wlid = flip (foldr f) $ zip [wlid..] $ loopPairs
& wlColor .~ col & wlColor .~ col
& wlStructure . wlStMachine .~ mcid & wlStructure . wlStMachine .~ mcid
placeLS :: LightSource -> Point3 -> Float -> World -> (Int,World) mvLS :: Point3 -> Float -> LightSource -> LightSource
placeLS ls (V3 x y z) rot w = (i, over lightSources addLS w) mvLS (V3 x y z) rot ls = ls {_lsPos = V3 x y z +.+.+ startPos,_lsDir = rot}
where where
i = IM.newKey $ _lightSources w
startPos = onXY (rotateV rot) $ _lsPos ls startPos = onXY (rotateV rot) $ _lsPos ls
addLS = IM.insert i (ls {_lsPos = V3 x y z +.+.+ startPos,_lsDir = rot,_lsID = i})
src/Dodge/LevelGen/Data.hs
+13 -10
View File
@@ -1,7 +1,6 @@
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE StrictData #-} {-# LANGUAGE StrictData #-}
module Dodge.LevelGen.Data module Dodge.LevelGen.Data where
where
import Dodge.Data import Dodge.Data
import Picture import Picture
import Geometry.Data import Geometry.Data
@@ -40,16 +39,20 @@ data PlacementSpot
data Placement = Placement data Placement = Placement
{ _plSpot :: PlacementSpot { _plSpot :: PlacementSpot
, _plType :: PSType , _plType :: PSType
, _plID :: Maybe Int
, _plIDCont :: Int -> Maybe Placement , _plIDCont :: Int -> Maybe Placement
} }
| PlacementUsingPos Point3 (Point3 -> Placement) -- allows a placement to use a shifted position | PlacementUsingPos Point3 (Point3 -> Placement) -- allows a placement to use a shifted position
| RandomPlacement {_unRandomPlacement :: State StdGen Placement} | RandomPlacement {_unRandomPlacement :: State StdGen Placement}
spNoID :: PlacementSpot -> PSType -> Placement
spNoID ps pst = Placement ps pst Nothing (const Nothing)
sPS :: Point2 -> Float -> PSType -> Placement sPS :: Point2 -> Float -> PSType -> Placement
sPS p a pt = Placement (PS p a) pt (const Nothing) sPS p a pt = Placement (PS p a) pt Nothing (const Nothing)
jsps :: Point2 -> Float -> PSType -> Maybe Placement jsps :: Point2 -> Float -> PSType -> Maybe Placement
jsps p a pst = Just $ Placement (PS p a) pst $ const Nothing jsps p a pst = Just $ Placement (PS p a) pst Nothing $ const Nothing
jsps0 :: PSType -> Maybe Placement jsps0 :: PSType -> Maybe Placement
jsps0 pst = Just $ sPS (V2 0 0) 0 pst jsps0 pst = Just $ sPS (V2 0 0) 0 pst
@@ -58,25 +61,25 @@ sps0 :: PSType -> Placement
sps0 = sPS (V2 0 0) 0 sps0 = sPS (V2 0 0) 0
jspsJ :: Point2 -> Float -> PSType -> Placement -> Maybe Placement jspsJ :: Point2 -> Float -> PSType -> Placement -> Maybe Placement
jspsJ p a pst plm = Just $ Placement (PS p a) pst $ \_ -> Just plm jspsJ p a pst plm = Just $ Placement (PS p a) pst Nothing $ \_ -> Just plm
jsps0J :: PSType -> Placement -> Maybe Placement jsps0J :: PSType -> Placement -> Maybe Placement
jsps0J pst plm = Just $ Placement (PS (V2 0 0) 0) pst $ \_ -> Just plm jsps0J pst plm = Just $ Placement (PS (V2 0 0) 0) pst Nothing $ \_ -> Just plm
ps0 :: PSType -> (Int -> Maybe Placement) -> Placement ps0 :: PSType -> (Int -> Maybe Placement) -> Placement
ps0 = Placement (PS (V2 0 0) 0) ps0 pst = Placement (PS (V2 0 0) 0) pst Nothing
jps0 :: PSType -> (Int -> Maybe Placement) -> Maybe Placement jps0 :: PSType -> (Int -> Maybe Placement) -> Maybe Placement
jps0 pst = Just . Placement (PS (V2 0 0) 0) pst jps0 pst = Just . Placement (PS (V2 0 0) 0) pst Nothing
ps0j :: PSType -> Placement -> Placement ps0j :: PSType -> Placement -> Placement
ps0j pst plmnt = Placement (PS (V2 0 0) 0) pst (const $ Just plmnt) ps0j pst plmnt = Placement (PS (V2 0 0) 0) pst Nothing (const $ Just plmnt)
addPlmnt :: Placement -> Placement -> Placement addPlmnt :: Placement -> Placement -> Placement
addPlmnt pl pl2 = case pl2 of addPlmnt pl pl2 = case pl2 of
(PlacementUsingPos p f) -> PlacementUsingPos p (fmap (addPlmnt pl) f) (PlacementUsingPos p f) -> PlacementUsingPos p (fmap (addPlmnt pl) f)
(RandomPlacement rp) -> RandomPlacement $ fmap (addPlmnt pl) rp (RandomPlacement rp) -> RandomPlacement $ fmap (addPlmnt pl) rp
(Placement ps pt f) -> Placement ps pt (fmap g f) (Placement ps pt mi f) -> Placement ps pt mi (fmap g f)
where where
g Nothing = Just pl g Nothing = Just pl
g (Just pl') = Just $ addPlmnt pl pl' g (Just pl') = Just $ addPlmnt pl pl'
src/Dodge/Placements/Door.hs
+2 -2
View File
@@ -17,7 +17,7 @@ putDoubleDoor pathing col cond a b speed = putDoubleDoorThen pathing col cond a
putDoubleDoorThen :: Bool -> Color -> (World -> Bool) putDoubleDoorThen :: Bool -> Color -> (World -> Bool)
-> Point2 -> Point2 -> Float -> Maybe Placement -> Placement -> Point2 -> Point2 -> Float -> Maybe Placement -> Placement
putDoubleDoorThen pathing col cond a b speed mayp = ps0j (PutSlideDoor pathing col cond a half speed) putDoubleDoorThen pathing col cond a b speed mayp = ps0j (PutSlideDoor pathing col cond a half speed)
$ Placement (PS (V2 0 0) 0) ( PutSlideDoor pathing col cond b half speed) $ const mayp $ Placement (PS (V2 0 0) 0) ( PutSlideDoor pathing col cond b half speed) Nothing $ const mayp
where where
half = 0.5 *.* (a +.+ b) half = 0.5 *.* (a +.+ b)
@@ -31,7 +31,7 @@ putAutoDoor a b = PlacementUsingPos (addZ 0 a)
cond az bz = any (crNearSeg 40 (stripZ az) (stripZ bz)) . IM.filter isAnimate . _creatures cond az bz = any (crNearSeg 40 (stripZ az) (stripZ bz)) . IM.filter isAnimate . _creatures
switchDoor :: Point2 -> Float -> Point2 -> Point2 -> Color -> Placement switchDoor :: Point2 -> Float -> Point2 -> Point2 -> Color -> Placement
switchDoor btpos btrot dra drb col = Placement (PS btpos btrot) (PutButton $ makeSwitch col red id id) switchDoor btpos btrot dra drb col = Placement (PS btpos btrot) (PutButton $ makeSwitch col red id id) Nothing
$ \btid -> jsps0J (PutSlideDoor False col (cond btid) dra drc 2) $ \btid -> jsps0J (PutSlideDoor False col (cond btid) dra drc 2)
$ sps0 (PutSlideDoor False col (cond btid) drb drc 2) $ sps0 (PutSlideDoor False col (cond btid) drb drc 2)
where where
src/Dodge/Placements/Sensor.hs
+1 -1
View File
@@ -15,7 +15,7 @@ import Data.Either
damageSensor damageSensor
:: (DamageType -> Either Int Int) -- Left gets sensed, Right does damage :: (DamageType -> Either Int Int) -- Left gets sensed, Right does damage
-> Point2 -> Float -> Placement -> Point2 -> Float -> Placement
damageSensor damF p r = Placement (PS p r) ( PutLS theLS) damageSensor damF p r = Placement (PS p r) ( PutLS theLS) Nothing
$ \lsid -> jsps p r $ PutMachine yellow (reverse $ square wdth) defaultMachine $ \lsid -> jsps p r $ PutMachine yellow (reverse $ square wdth) defaultMachine
{ _mcDraw = sensorSPic { _mcDraw = sensorSPic
, _mcUpdate = sensorUpdate damF , _mcUpdate = sensorUpdate damF
src/Dodge/Placements/Spot.hs
+3 -3
View File
@@ -13,16 +13,16 @@ updatePSToLevel :: Int -> (PlacementSpot -> PlacementSpot) -> Placement -> Place
updatePSToLevel 0 _ plmnt = plmnt updatePSToLevel 0 _ plmnt = plmnt
updatePSToLevel i f plmnt = case plmnt of updatePSToLevel i f plmnt = case plmnt of
PlacementUsingPos p pl -> PlacementUsingPos p (fmap (updatePSToLevel i f) pl) PlacementUsingPos p pl -> PlacementUsingPos p (fmap (updatePSToLevel i f) pl)
Placement ps pt pl -> Placement (f ps) pt (fmap (fmap (updatePSToLevel (i-1) f)) pl) Placement ps pt mi pl -> Placement (f ps) pt mi (fmap (fmap (updatePSToLevel (i-1) f)) pl)
RandomPlacement rplmnt -> RandomPlacement $ fmap (updatePSToLevel i f) rplmnt RandomPlacement rplmnt -> RandomPlacement $ fmap (updatePSToLevel i f) rplmnt
setLocalPS :: PlacementSpot -> Placement -> Placement setLocalPS :: PlacementSpot -> Placement -> Placement
setLocalPS ps (Placement _ pt f) = Placement ps pt f setLocalPS ps (Placement _ pt mi f) = Placement ps pt mi f
setLocalPS ps (RandomPlacement rplmnt) = RandomPlacement (fmap (setLocalPS ps) rplmnt) setLocalPS ps (RandomPlacement rplmnt) = RandomPlacement (fmap (setLocalPS ps) rplmnt)
setLocalPS _ plmnt = plmnt setLocalPS _ plmnt = plmnt
updatePS :: (PlacementSpot -> PlacementSpot) -> Placement -> Placement updatePS :: (PlacementSpot -> PlacementSpot) -> Placement -> Placement
updatePS f pl' = case pl' of updatePS f pl' = case pl' of
Placement ps pt ipl -> Placement (f ps) pt $ (fmap . fmap $ updatePS f) ipl Placement ps pt mi ipl -> Placement (f ps) pt mi $ (fmap . fmap $ updatePS f) ipl
PlacementUsingPos p pl -> PlacementUsingPos p (fmap (updatePS f) pl) PlacementUsingPos p pl -> PlacementUsingPos p (fmap (updatePS f) pl)
RandomPlacement rpl -> RandomPlacement (fmap (updatePS f) rpl) RandomPlacement rpl -> RandomPlacement (fmap (updatePS f) rpl)
src/Dodge/Room.hs
+9 -9
View File
@@ -137,8 +137,8 @@ glassSwitchBack = do
glassSwitchBackCrits :: RandomGen g => State g Room glassSwitchBackCrits :: RandomGen g => State g Room
glassSwitchBackCrits = glassSwitchBack glassSwitchBackCrits = glassSwitchBack
<&> rmPmnts %~ ([Placement (PSRoomRand 0) (PutCrit miniGunCrit) (const Nothing) <&> rmPmnts %~ ([spNoID (PSRoomRand 0) (PutCrit miniGunCrit)
, Placement (PSRoomRand 1) randC1 (const Nothing) , spNoID (PSRoomRand 1) randC1
] ++) ] ++)
miniTree2 :: RandomGen g => State g (Tree (Either Room Room)) miniTree2 :: RandomGen g => State g (Tree (Either Room Room))
@@ -351,7 +351,7 @@ weaponRoom = join $ takeOne
roomCCrits :: RandomGen g => State g Room roomCCrits :: RandomGen g => State g Room
roomCCrits = roomC 200 200 roomCCrits = roomC 200 200
<&> rmPmnts %~ (replicate 20 (Placement (PSRoomRand 0) randC1 (const Nothing)) ++ ) <&> rmPmnts %~ (replicate 20 (spNoID (PSRoomRand 0) randC1) ++ )
longRoom :: RandomGen g => State g Room longRoom :: RandomGen g => State g Room
longRoom = do longRoom = do
@@ -418,13 +418,13 @@ shootersRoom' = do
shootersRoom1 :: RandomGen g => State g Room shootersRoom1 :: RandomGen g => State g Room
shootersRoom1 = shootersRoom' <&> rmPmnts %~ shootersRoom1 = shootersRoom' <&> rmPmnts %~
( ( ( (
RandomPlacement $ takeOne $ map (\i -> Placement (PSRoomRand i) (PutCrit autoCrit) (const Nothing)) RandomPlacement $ takeOne $ map (\i -> spNoID (PSRoomRand i) (PutCrit autoCrit))
[0,1,2] [0,1,2]
) :) ) :)
shootersRoom :: RandomGen g => State g Room shootersRoom :: RandomGen g => State g Room
shootersRoom = shootersRoom' <&> rmPmnts %~ shootersRoom = shootersRoom' <&> rmPmnts %~
( map (\i -> Placement (PSRoomRand i) (PutCrit autoCrit) (const Nothing)) ( map (\i -> spNoID (PSRoomRand i) (PutCrit autoCrit))
[0,1,2] [0,1,2]
++ ) ++ )
@@ -461,9 +461,9 @@ pillarGrid = do
pistolerRoom :: RandomGen g => State g Room pistolerRoom :: RandomGen g => State g Room
pistolerRoom = pillarGrid pistolerRoom = pillarGrid
<&> rmPmnts %~ ( <&> rmPmnts %~ (
[Placement (PSRoomRand 0) (PutCrit pistolCrit) (const Nothing) [spNoID (PSRoomRand 0) (PutCrit pistolCrit)
,Placement (PSRoomRand 0) (PutCrit pistolCrit) (const Nothing) ,spNoID (PSRoomRand 0) (PutCrit pistolCrit)
,Placement (PSRoomRand 0) (PutCrit pistolCrit) (const Nothing) ,spNoID (PSRoomRand 0) (PutCrit pistolCrit)
] ]
++) ++)
@@ -490,6 +490,6 @@ spawnerRoom = do
x <- state $ randomR (250,300) x <- state $ randomR (250,300)
y <- state $ randomR (300,400) y <- state $ randomR (300,400)
roomWithSpawner <- roomC x y <&> roomWithSpawner <- roomC x y <&>
rmPmnts %~ (Placement (PSRoomRand 0) (PutCrit spawnerCrit) (const Nothing) :) rmPmnts %~ (spNoID (PSRoomRand 0) (PutCrit spawnerCrit) :)
aRoom <- airlock aRoom <- airlock
return $ treeFromTrunk [Left aRoom,Left corridor] $ connectRoom roomWithSpawner return $ treeFromTrunk [Left aRoom,Left corridor] $ connectRoom roomWithSpawner
src/Dodge/Room/Airlock.hs
+5 -5
View File
@@ -27,7 +27,7 @@ airlock0 = defaultRoom
, _rmLinks = lnks , _rmLinks = lnks
, _rmPath = [(V2 20 95,V2 20 45) ,(V2 20 45,V2 20 5) ] , _rmPath = [(V2 20 95,V2 20 45) ,(V2 20 45,V2 20 5) ]
, _rmPmnts = , _rmPmnts =
[Placement (PS (V2 (-35) 50) (negate $ pi/2)) (PutButton $ makeSwitch col red id id) [Placement (PS (V2 (-35) 50) (negate $ pi/2)) (PutButton $ makeSwitch col red id id) Nothing
$ \btid -> Just $ putDoubleDoorThen False col (not . cond' btid) (V2 (-1) 20) (V2 41 20) 2 $ \btid -> Just $ putDoubleDoorThen False col (not . cond' btid) (V2 (-1) 20) (V2 41 20) 2
$ Just $ putDoubleDoorThen False col (cond' btid) (V2 (-1) 80) (V2 41 80) 2 Nothing $ Just $ putDoubleDoorThen False col (cond' btid) (V2 (-1) 80) (V2 41 80) 2 Nothing
,spanLightI (V2 (-2) 30) (V2 (-2) 70) ,spanLightI (V2 (-2) 30) (V2 (-2) 70)
@@ -49,7 +49,7 @@ airlockSimple = defaultRoom
, _rmLinks = lnks , _rmLinks = lnks
, _rmPath = concatMap (doublePair. (V2 90 30,) . fst) lnks , _rmPath = concatMap (doublePair. (V2 90 30,) . fst) lnks
, _rmPmnts = , _rmPmnts =
[ Placement (PS (V2 90 115) pi) (PutButton $ makeSwitch col red id id) [ Placement (PS (V2 90 115) pi) (PutButton $ makeSwitch col red id id) Nothing
$ \btid -> jspsJ (V2 0 0) 0 (PutDoor col (cond btid) outDoorps) $ \btid -> jspsJ (V2 0 0) 0 (PutDoor col (cond btid) outDoorps)
$ sPS (V2 180 0) 0 (PutDoor col (cond btid) inDoorps) $ sPS (V2 180 0) 0 (PutDoor col (cond btid) inDoorps)
] ]
@@ -78,7 +78,7 @@ airlockZ = defaultRoom
-- ,(V2 40 0,V2 0 40) -- ,(V2 40 0,V2 0 40)
-- ] -- ]
, _rmPmnts = , _rmPmnts =
[ Placement (PS (V2 90 115) pi) (PutButton $ makeSwitch col red id id) [ Placement (PS (V2 90 115) pi) (PutButton $ makeSwitch col red id id) Nothing
$ \btid -> jspsJ (V2 0 60) 0 (PutDoor col (cond btid) outDoorps) $ \btid -> jspsJ (V2 0 60) 0 (PutDoor col (cond btid) outDoorps)
$ sPS (V2 180 60) 0 (PutDoor col (cond btid) inDoorps) $ sPS (V2 180 60) 0 (PutDoor col (cond btid) inDoorps)
, sps0 $ PutWall (rectNSEW 70 50 120 60) defaultWall , sps0 $ PutWall (rectNSEW 70 50 120 60) defaultWall
@@ -118,7 +118,7 @@ airlock90 = defaultRoom
,(V2 40 0,V2 0 40) ,(V2 40 0,V2 0 40)
] ]
, _rmPmnts = , _rmPmnts =
[ Placement (PS (V2 120 120) (3 * pi/4)) (PutButton $ makeSwitch col red id id) [ Placement (PS (V2 120 120) (3 * pi/4)) (PutButton $ makeSwitch col red id id) Nothing
$ \btid -> jsps (V2 5 5) 0 $ PutDoor col (cond btid) pss $ \btid -> jsps (V2 5 5) 0 $ PutDoor col (cond btid) pss
,mountLightV (V2 20 20) (V3 70 70 50) ,mountLightV (V2 20 20) (V3 70 70 50)
] ]
@@ -146,7 +146,7 @@ airlockCrystal = defaultRoom
, _rmLinks = [(V2 20 130,0) ,(V2 20 0 ,pi) ] , _rmLinks = [(V2 20 130,0) ,(V2 20 0 ,pi) ]
, _rmPath = [ ] , _rmPath = [ ]
, _rmPmnts = , _rmPmnts =
[ Placement (PS (V2 145 70) (pi/2)) ( PutButton $ makeSwitch col red id id) [ Placement (PS (V2 145 70) (pi/2)) ( PutButton $ makeSwitch col red id id) Nothing
$ \btid -> jsps0 $ PutDoor col (cond btid) pss $ \btid -> jsps0 $ PutDoor col (cond btid) pss
, crystalLine (V2 0 70) (V2 40 70) , crystalLine (V2 0 70) (V2 40 70)
, mountLightV (V2 150 70) (V3 110 70 70) , mountLightV (V2 150 70) (V3 110 70 70)
src/Dodge/Room/Data.hs
+5 -6
View File
@@ -5,12 +5,11 @@ module Dodge.Room.Data
import Dodge.LevelGen.Data import Dodge.LevelGen.Data
import Geometry.Data import Geometry.Data
import Data.Tile import Data.Tile
import Dodge.Data
import Control.Monad.State import Control.Monad.State
import System.Random import System.Random
import Control.Lens import Control.Lens
import qualified Data.IntMap.Strict as IM --import qualified Data.IntMap.Strict as IM
{- {-
The '_rmPolys' list states which polygons should be cut out to form the indestructible walls of the room. The '_rmPolys' list states which polygons should be cut out to form the indestructible walls of the room.
Link pairs contain a position and rotation to attach to another room; Link pairs contain a position and rotation to attach to another room;
@@ -26,16 +25,16 @@ data Room = Room
, _rmPos :: [RoomPos] , _rmPos :: [RoomPos]
, _rmPath :: [(Point2, Point2)] , _rmPath :: [(Point2, Point2)]
, _rmPmnts :: [Placement] , _rmPmnts :: [Placement]
, _rmTriggers :: IM.IntMap (World -> Bool) , _rmPartialPmnt :: Maybe (Int -> Placement)
, _rmTriggerPmnts :: IM.IntMap ((World -> Bool) -> Placement) , _rmExtendedPmnt :: Maybe Placement
, _rmBound :: [ [Point2] ] , _rmBound :: [ [Point2] ]
, _rmFloor :: [Tile] , _rmFloor :: [Tile]
, _rmName :: String , _rmName :: String
, _rmShift :: (Point2, Float) , _rmShift :: (Point2, Float)
, _rmViewpoints :: [Point2] , _rmViewpoints :: [Point2]
, _rmRandPSs :: [State StdGen (Point2,Float)] , _rmRandPSs :: [State StdGen (Point2,Float)]
, _rmLabel :: Maybe Int , _rmLabel :: Maybe Int
, _rmTakeFrom :: Maybe Int , _rmTakeFrom :: Maybe Int
} }
data RoomPos data RoomPos
= OutLink Int Point2 Float = OutLink Int Point2 Float
src/Dodge/Room/Door.hs
+2 -4
View File
@@ -5,9 +5,9 @@ import Geometry
import Dodge.Room.Data import Dodge.Room.Data
import Dodge.Default.Room import Dodge.Default.Room
import Dodge.Placements import Dodge.Placements
import Color --import Color
import qualified Data.IntMap.Strict as IM --import qualified Data.IntMap.Strict as IM
door :: Room door :: Room
door = defaultRoom door = defaultRoom
@@ -30,8 +30,6 @@ switchDoor = defaultRoom
, _rmLinks = lnks , _rmLinks = lnks
, _rmPath = [(V2 20 35,V2 20 5)] , _rmPath = [(V2 20 35,V2 20 5)]
-- door extends into side walls (for shadows as rendered 12/03) -- door extends into side walls (for shadows as rendered 12/03)
, _rmTriggerPmnts = IM.fromList
[(0,\cond -> putDoubleDoor False red cond (V2 0 20) (V2 40 20) 2)]
-- note no bounds -- note no bounds
} }
where where
src/Dodge/Room/LongDoor.hs
+1 -1
View File
@@ -39,7 +39,7 @@ twinSlowDoorRoom w h x = defaultRoom
] ]
, _rmPath = [] , _rmPath = []
, _rmPmnts = , _rmPmnts =
[ Placement (PS (V2 0 (h-5)) pi) ( PutButton $ makeButton col id) [ Placement (PS (V2 0 (h-5)) pi) ( PutButton $ makeButton col id) Nothing
$ \btid -> jsps0J (PutSlideDoor False col (cond' btid) (V2 x 1) (V2 x h) wlSpeed) $ \btid -> jsps0J (PutSlideDoor False col (cond' btid) (V2 x 1) (V2 x h) wlSpeed)
$ ps0 (PutSlideDoor False col (cond' btid) (V2 (-x) 1) (V2 (-x) h) wlSpeed) $ ps0 (PutSlideDoor False col (cond' btid) (V2 (-x) 1) (V2 (-x) h) wlSpeed)
$ \did -> jps0 (PutLS (colorLightAt (V3 0.75 0 0) (V3 0 (h-1) lampHeight) 0)) $ \did -> jps0 (PutLS (colorLightAt (V3 0.75 0 0) (V3 0 (h-1) lampHeight) 0))
src/Dodge/Room/Procedural.hs
+2 -2
View File
@@ -175,7 +175,7 @@ fillNothingPlacement :: PSType -> Room -> Room
fillNothingPlacement pst r = fillNothingPlacement pst r =
r & rmPmnts %~ replaceNothingWith pst r & rmPmnts %~ replaceNothingWith pst
where where
replaceNothingWith x (Placement (PS p rot) PutNothing _: pss) = sPS p rot x : pss replaceNothingWith x (Placement (PS p rot) PutNothing _ _: pss) = sPS p rot x : pss
replaceNothingWith x (ps:pss) = ps : replaceNothingWith x pss replaceNothingWith x (ps:pss) = ps : replaceNothingWith x pss
replaceNothingWith _ [] = [] replaceNothingWith _ [] = []
{- | Successively fill 'PutNothing' placements with a list of given 'PSType's. {- | Successively fill 'PutNothing' placements with a list of given 'PSType's.
@@ -237,7 +237,7 @@ centerVaultRoom w h d = do
where where
col = dim $ dim $ bright red col = dim $ dim $ bright red
theDoor = theDoor =
[ Placement (PS (V2 35 (d+4)) 0) (PutButton $ makeSwitch col red id id) [ Placement (PS (V2 35 (d+4)) 0) (PutButton $ makeSwitch col red id id) Nothing
$ \btid -> jspsJ (V2 0 (d-10)) 0 (PutSlideDoor False col (cond' btid) (V2 (-21) 0) (V2 0 0) 2) $ \btid -> jspsJ (V2 0 (d-10)) 0 (PutSlideDoor False col (cond' btid) (V2 (-21) 0) (V2 0 0) 2)
$ sPS (V2 0 (d-10)) 0 (PutSlideDoor False col (cond' btid) (V2 21 0) (V2 0 0) 2) $ sPS (V2 0 (d-10)) 0 (PutSlideDoor False col (cond' btid) (V2 21 0) (V2 0 0) 2)
] ]