Move towards more usable placements
This commit is contained in:
@@ -3,7 +3,6 @@ module Dodge.Default.Room
|
||||
import Geometry.Data
|
||||
import Dodge.Room.Data
|
||||
|
||||
import qualified Data.IntMap.Strict as IM
|
||||
defaultRoom :: Room
|
||||
defaultRoom = Room
|
||||
{ _rmPolys = []
|
||||
@@ -11,8 +10,8 @@ defaultRoom = Room
|
||||
, _rmPos = []
|
||||
, _rmPath = []
|
||||
, _rmPmnts = []
|
||||
, _rmTriggerPmnts = IM.empty
|
||||
, _rmTriggers = IM.empty
|
||||
, _rmPartialPmnt = Nothing
|
||||
, _rmExtendedPmnt = Nothing
|
||||
, _rmBound = []
|
||||
, _rmFloor = []
|
||||
, _rmName = "defaultRoom"
|
||||
|
||||
+61
-64
@@ -1,34 +1,29 @@
|
||||
--{-# LANGUAGE TupleSections #-}
|
||||
module Dodge.Layout
|
||||
where
|
||||
( generateLevelFromRoomList
|
||||
, doPartialPlacements
|
||||
, doExtendedPlacements
|
||||
) where
|
||||
import Dodge.Data
|
||||
import Dodge.LevelGen
|
||||
import Dodge.LevelGen.Data
|
||||
import Dodge.LevelGen.StaticWalls
|
||||
import Dodge.LevelGen.Pathing
|
||||
import Dodge.Wall.Zone
|
||||
import Dodge.Zone
|
||||
import Dodge.GameRoom
|
||||
import Dodge.Bounds
|
||||
import Dodge.Layout.Tree.Polymorphic (applyToRoot)
|
||||
import Dodge.Room.Data
|
||||
import Dodge.Room.AddTile
|
||||
import Dodge.Default.Wall
|
||||
import Geometry
|
||||
--import Geometry.Data
|
||||
import Dodge.Room.Link
|
||||
import qualified IntMapHelp as IM
|
||||
--import Dodge.Debug.LinkDecoration
|
||||
import Picture.Data
|
||||
import Tile
|
||||
import Polyhedra
|
||||
import Polyhedra.Data
|
||||
|
||||
import Data.List (nubBy)
|
||||
--import Control.Monad.State
|
||||
import Control.Lens
|
||||
import System.Random
|
||||
import Data.Tree
|
||||
--import Data.Graph.Inductive.Graph (labNodes)
|
||||
--import qualified Data.Map as M
|
||||
import Data.Foldable
|
||||
@@ -52,13 +47,29 @@ generateLevelFromRoomList gr w
|
||||
rs = zipWith addTile zs gr
|
||||
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 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 w = w
|
||||
& worldBounds . bdMinX .~ f minx
|
||||
@@ -75,8 +86,8 @@ setupWorldBounds w = w
|
||||
<*> L.premap sndV2 L.maximum
|
||||
) ps
|
||||
|
||||
polyhedrasToEdges :: [Polyhedra] -> [Point3]
|
||||
polyhedrasToEdges = concatMap tflat4 . concatMap polyToEdges
|
||||
--polyhedrasToEdges :: [Polyhedra] -> [Point3]
|
||||
--polyhedrasToEdges = concatMap tflat4 . concatMap polyToEdges
|
||||
|
||||
initWallZoning :: World -> World
|
||||
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
|
||||
-- wallInZone wl = flip (foldl' (flip $ \(a,b) -> insertIMInZone a b (_wlID wl) wl)) (zoneOfWall wl)
|
||||
|
||||
makePath :: Tree Room -> [(Point2,Point2)]
|
||||
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}
|
||||
--makePath :: Tree Room -> [(Point2,Point2)]
|
||||
--makePath = concatMap _rmPath . flatten
|
||||
|
||||
wallsFromRooms :: [Room] -> IM.IntMap Wall
|
||||
wallsFromRooms =
|
||||
@@ -132,40 +129,40 @@ gameRoomsFromRooms = map f
|
||||
floorsFromRooms :: [Room] -> [(Point3,Point3)]
|
||||
floorsFromRooms = concatMap (concatMap tToRender . _rmFloor)
|
||||
|
||||
divideWall :: Wall -> [Wall]
|
||||
divideWall wl
|
||||
= let (a,b) = _wlLine wl
|
||||
ps = divideLine (zoneSize * 2) a b
|
||||
in zipWith (\ x y -> wl & wlLine .~ (x,y) ) (init ps) (tail ps)
|
||||
--divideWall :: Wall -> [Wall]
|
||||
--divideWall wl
|
||||
-- = let (a,b) = _wlLine wl
|
||||
-- ps = divideLine (zoneSize * 2) a b
|
||||
-- in zipWith (\ x y -> wl & wlLine .~ (x,y) ) (init ps) (tail ps)
|
||||
|
||||
divideWallIn :: Wall -> IM.IntMap Wall -> IM.IntMap Wall
|
||||
divideWallIn wl wls =
|
||||
let (wl':newWls) = divideWall wl
|
||||
k = IM.newKey wls
|
||||
newWls' = zipWith (\i w -> w {_wlID = i}) [k..] newWls
|
||||
in foldl' (flip $ \w -> IM.insert (_wlID w) w) wls (wl':newWls')
|
||||
--divideWallIn :: Wall -> IM.IntMap Wall -> IM.IntMap Wall
|
||||
--divideWallIn wl wls =
|
||||
-- let (wl':newWls) = divideWall wl
|
||||
-- k = IM.newKey wls
|
||||
-- newWls' = zipWith (\i w -> w {_wlID = i}) [k..] 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
|
||||
divideWalls wls = foldl' (flip divideWallIn) wls wls
|
||||
--insertInZone :: Int -> Int -> a -> IM.IntMap (IM.IntMap a) -> IM.IntMap (IM.IntMap a)
|
||||
--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)
|
||||
insertInZone x y obj = IM.insertWith f x $ IM.singleton y obj
|
||||
where f _ = IM.insert y obj
|
||||
--shiftRoomTree :: Tree Room -> Tree Room
|
||||
--shiftRoomTree (Node t []) = Node t []
|
||||
--shiftRoomTree (Node t ts) = Node t
|
||||
-- $ zipWith (\l -> shiftRoomTree . applyToRoot (shiftRoomToLink l))
|
||||
-- (_rmLinks t)
|
||||
-- ts
|
||||
|
||||
shiftRoomTree :: Tree Room -> Tree Room
|
||||
shiftRoomTree (Node t []) = Node t []
|
||||
shiftRoomTree (Node t ts) = Node t
|
||||
$ zipWith (\l -> shiftRoomTree . applyToRoot (shiftRoomToLink l))
|
||||
(_rmLinks t)
|
||||
ts
|
||||
|
||||
shiftRoomTreeConstruction :: Tree Room -> [Tree Room]
|
||||
shiftRoomTreeConstruction (Node t []) = [Node t []]
|
||||
shiftRoomTreeConstruction (Node t ts) = (Node t [] :) $ concat $
|
||||
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
|
||||
--shiftRoomTreeConstruction :: Tree Room -> [Tree Room]
|
||||
--shiftRoomTreeConstruction (Node t []) = [Node t []]
|
||||
--shiftRoomTreeConstruction (Node t ts) = (Node t [] :) $ concat $
|
||||
-- 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
|
||||
|
||||
+61
-98
@@ -23,37 +23,15 @@ import Shape
|
||||
import qualified IntMapHelp as IM
|
||||
import Color
|
||||
|
||||
import System.Random
|
||||
import Control.Monad.State
|
||||
import Control.Lens
|
||||
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 (w,rm) plmnt = case plmnt of
|
||||
Placement{_plSpot = PSRoomRand i} -> 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)
|
||||
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{_plSpot = PSLnk{}} -> placeSpotUsingLink w rm plmnt
|
||||
Placement{} ->
|
||||
let (i,w') = placeSpotID (shiftPSBy shift (_plSpot plmnt)) (_plType plmnt) w
|
||||
in maybe (w',rm) (placeSpot (w',rm)) (_plIDCont plmnt i)
|
||||
@@ -64,15 +42,40 @@ placeSpot (w,rm) plmnt = case plmnt of
|
||||
where
|
||||
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 i xs = take i xs ++ drop (i+1) xs
|
||||
|
||||
shiftPlacement :: (Point2,Float) -> Placement -> Placement
|
||||
shiftPlacement shift (Placement ps pt f) = Placement (shiftPSBy shift ps) pt
|
||||
(fmap (fmap $ shiftPlacement shift) f)
|
||||
shiftPlacement shift (PlacementUsingPos p f) = PlacementUsingPos (shiftPoint3By shift p)
|
||||
(fmap (shiftPlacement shift) f)
|
||||
shiftPlacement shift (RandomPlacement rpl) = RandomPlacement $ fmap (shiftPlacement shift) rpl
|
||||
shiftPlacement shift plmnt = case plmnt of
|
||||
Placement {} -> plmnt & plSpot %~ shiftPSBy shift
|
||||
& plIDCont %~ fmap (fmap $ shiftPlacement shift)
|
||||
PlacementUsingPos p f -> PlacementUsingPos (shiftPoint3By shift p)
|
||||
(fmap (shiftPlacement shift) f)
|
||||
RandomPlacement rpl -> RandomPlacement $ fmap (shiftPlacement shift) rpl
|
||||
|
||||
shiftPSBy :: (Point2,Float) -> PlacementSpot -> PlacementSpot
|
||||
shiftPSBy (pos,rot) ps = ps
|
||||
@@ -84,17 +87,14 @@ shiftPSBy (pos,rot) ps = ps
|
||||
placeSpotID :: PlacementSpot -> PSType -> World -> (Int, World)
|
||||
placeSpotID ps pt w = case pt of
|
||||
PutTrigger cond -> placeNewInto triggers cond w
|
||||
PutProp prop -> placeProp prop p rot w
|
||||
--PutButton bt -> placeBt bt p rot w
|
||||
PutButton bt -> placeNewUpdateID buttons btID (mvButton bt p rot) w
|
||||
PutFlIt itm -> placeFlIt itm p rot w
|
||||
PutCrit cr -> placeCr cr p rot w
|
||||
PutProp prop -> plNewUpID props pjID (mvProp p rot prop) w
|
||||
PutButton bt -> plNewUpID buttons btID (mvButton p rot bt) w
|
||||
PutFlIt itm -> plNewUpID floorItems flItID (createFlIt p rot itm) w
|
||||
PutCrit cr -> plNewUpID creatures crID (mvCr p rot cr) w
|
||||
PutMachine col wallpoly mc -> placeMachine col (map doShift wallpoly) mc p rot w
|
||||
PutLS ls -> placeLS ls p' rot w
|
||||
PutPressPlate pp -> placePressPlate pp p rot w
|
||||
RandPS rgen -> placeSpotID ps evaluatedType (set randGen g w)
|
||||
where
|
||||
(evaluatedType, g) = runState rgen (_randGen w)
|
||||
PutLS ls -> plNewUpID lightSources lsID (mvLS p' rot ls) w
|
||||
PutPressPlate pp -> plNewUpID pressPlates ppID (mvPP p rot pp) w
|
||||
RandPS rgen -> evaluateRandPS rgen ps w
|
||||
PutDoor col f pss -> placeDoor col f (map (bimap doShift doShift) pss) 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
|
||||
@@ -112,6 +112,11 @@ placeSpotID ps pt w = case pt of
|
||||
rot = _psRot ps
|
||||
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 ps wl = rmCrossPaths . over walls (addWalls ps wl)
|
||||
where
|
||||
@@ -148,71 +153,30 @@ placeNewInto l x w = (i,w & l #%~ IM.insert i x)
|
||||
i = IM.newKey $ w ^# l
|
||||
|
||||
-- | 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
|
||||
-> a
|
||||
-> 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
|
||||
i = IM.newKey $ w ^# l
|
||||
|
||||
placeProp
|
||||
:: Prop
|
||||
-> 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)
|
||||
mvProp :: Point2 -> Float -> Prop -> Prop
|
||||
mvProp p a = (pjRot +~ a) . (pjPos %~ ( (p +.+) . rotateV a ))
|
||||
|
||||
placeBt
|
||||
:: Button
|
||||
-> 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 :: Point2 -> Float -> Button -> Button
|
||||
mvButton p a = (btRot +~ a) . (btPos %~ ( (p +.+) . rotateV a ))
|
||||
|
||||
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.
|
||||
Assigns an id correctly. -}
|
||||
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
|
||||
mvPP :: Point2 -> Float -> PressPlate -> PressPlate
|
||||
mvPP p rot pp = pp {_ppPos = p,_ppRot = rot}
|
||||
|
||||
placePressPlate
|
||||
:: PressPlate
|
||||
-> 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
|
||||
mvCr :: Point2 -> Float -> Creature -> Creature
|
||||
mvCr p rot cr = cr {_crPos = p,_crOldPos = p,_crDir = rot}
|
||||
|
||||
placeMachine :: Color -> [Point2] -> Machine -> Point2 -> Float -> World -> (Int,World)
|
||||
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
|
||||
wlids = IS.fromList [wlid .. wlid + length wallpoly - 1]
|
||||
addMc mcs = IM.insert mcid (mc {_mcPos = p,_mcDir = rot,_mcID = mcid, _mcWallIDs = wlids}) mcs
|
||||
|
||||
-- TODO correctly remove/shift pathfinding lines (removePathsCrossing)
|
||||
placeMachineWalls :: Color -> [Point2] -> Int -> Int -> IM.IntMap Wall -> IM.IntMap Wall
|
||||
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
|
||||
& wlStructure . wlStMachine .~ mcid
|
||||
|
||||
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
|
||||
mvLS :: Point3 -> Float -> LightSource -> LightSource
|
||||
mvLS (V3 x y z) rot ls = ls {_lsPos = V3 x y z +.+.+ startPos,_lsDir = rot}
|
||||
where
|
||||
startPos = onXY (rotateV rot) $ _lsPos ls
|
||||
addLS = IM.insert i (ls {_lsPos = V3 x y z +.+.+ startPos,_lsDir = rot,_lsID = i})
|
||||
|
||||
+13
-10
@@ -1,7 +1,6 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE StrictData #-}
|
||||
module Dodge.LevelGen.Data
|
||||
where
|
||||
module Dodge.LevelGen.Data where
|
||||
import Dodge.Data
|
||||
import Picture
|
||||
import Geometry.Data
|
||||
@@ -40,16 +39,20 @@ data PlacementSpot
|
||||
data Placement = Placement
|
||||
{ _plSpot :: PlacementSpot
|
||||
, _plType :: PSType
|
||||
, _plID :: Maybe Int
|
||||
, _plIDCont :: Int -> Maybe Placement
|
||||
}
|
||||
| PlacementUsingPos Point3 (Point3 -> Placement) -- allows a placement to use a shifted position
|
||||
| RandomPlacement {_unRandomPlacement :: State StdGen Placement}
|
||||
|
||||
spNoID :: PlacementSpot -> PSType -> Placement
|
||||
spNoID ps pst = Placement ps pst Nothing (const Nothing)
|
||||
|
||||
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 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 pst = Just $ sPS (V2 0 0) 0 pst
|
||||
@@ -58,25 +61,25 @@ sps0 :: PSType -> Placement
|
||||
sps0 = sPS (V2 0 0) 0
|
||||
|
||||
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 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 = Placement (PS (V2 0 0) 0)
|
||||
ps0 pst = Placement (PS (V2 0 0) 0) pst Nothing
|
||||
|
||||
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 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 pl pl2 = case pl2 of
|
||||
(PlacementUsingPos p f) -> PlacementUsingPos p (fmap (addPlmnt pl) f)
|
||||
(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
|
||||
g Nothing = Just pl
|
||||
g (Just pl') = Just $ addPlmnt pl pl'
|
||||
|
||||
@@ -17,7 +17,7 @@ putDoubleDoor pathing col cond a b speed = putDoubleDoorThen pathing col cond a
|
||||
putDoubleDoorThen :: Bool -> Color -> (World -> Bool)
|
||||
-> Point2 -> Point2 -> Float -> Maybe Placement -> Placement
|
||||
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
|
||||
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
|
||||
|
||||
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)
|
||||
$ sps0 (PutSlideDoor False col (cond btid) drb drc 2)
|
||||
where
|
||||
|
||||
@@ -15,7 +15,7 @@ import Data.Either
|
||||
damageSensor
|
||||
:: (DamageType -> Either Int Int) -- Left gets sensed, Right does damage
|
||||
-> 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
|
||||
{ _mcDraw = sensorSPic
|
||||
, _mcUpdate = sensorUpdate damF
|
||||
|
||||
@@ -13,16 +13,16 @@ updatePSToLevel :: Int -> (PlacementSpot -> PlacementSpot) -> Placement -> Place
|
||||
updatePSToLevel 0 _ plmnt = plmnt
|
||||
updatePSToLevel i f plmnt = case plmnt of
|
||||
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
|
||||
|
||||
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 _ plmnt = plmnt
|
||||
|
||||
updatePS :: (PlacementSpot -> PlacementSpot) -> Placement -> Placement
|
||||
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)
|
||||
RandomPlacement rpl -> RandomPlacement (fmap (updatePS f) rpl)
|
||||
|
||||
+9
-9
@@ -137,8 +137,8 @@ glassSwitchBack = do
|
||||
|
||||
glassSwitchBackCrits :: RandomGen g => State g Room
|
||||
glassSwitchBackCrits = glassSwitchBack
|
||||
<&> rmPmnts %~ ([Placement (PSRoomRand 0) (PutCrit miniGunCrit) (const Nothing)
|
||||
, Placement (PSRoomRand 1) randC1 (const Nothing)
|
||||
<&> rmPmnts %~ ([spNoID (PSRoomRand 0) (PutCrit miniGunCrit)
|
||||
, spNoID (PSRoomRand 1) randC1
|
||||
] ++)
|
||||
|
||||
miniTree2 :: RandomGen g => State g (Tree (Either Room Room))
|
||||
@@ -351,7 +351,7 @@ weaponRoom = join $ takeOne
|
||||
|
||||
roomCCrits :: RandomGen g => State g Room
|
||||
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 = do
|
||||
@@ -418,13 +418,13 @@ shootersRoom' = do
|
||||
shootersRoom1 :: RandomGen g => State g Room
|
||||
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]
|
||||
) :)
|
||||
|
||||
shootersRoom :: RandomGen g => State g Room
|
||||
shootersRoom = shootersRoom' <&> rmPmnts %~
|
||||
( map (\i -> Placement (PSRoomRand i) (PutCrit autoCrit) (const Nothing))
|
||||
( map (\i -> spNoID (PSRoomRand i) (PutCrit autoCrit))
|
||||
[0,1,2]
|
||||
++ )
|
||||
|
||||
@@ -461,9 +461,9 @@ pillarGrid = do
|
||||
pistolerRoom :: RandomGen g => State g Room
|
||||
pistolerRoom = pillarGrid
|
||||
<&> rmPmnts %~ (
|
||||
[Placement (PSRoomRand 0) (PutCrit pistolCrit) (const Nothing)
|
||||
,Placement (PSRoomRand 0) (PutCrit pistolCrit) (const Nothing)
|
||||
,Placement (PSRoomRand 0) (PutCrit pistolCrit) (const Nothing)
|
||||
[spNoID (PSRoomRand 0) (PutCrit pistolCrit)
|
||||
,spNoID (PSRoomRand 0) (PutCrit pistolCrit)
|
||||
,spNoID (PSRoomRand 0) (PutCrit pistolCrit)
|
||||
]
|
||||
++)
|
||||
|
||||
@@ -490,6 +490,6 @@ spawnerRoom = do
|
||||
x <- state $ randomR (250,300)
|
||||
y <- state $ randomR (300,400)
|
||||
roomWithSpawner <- roomC x y <&>
|
||||
rmPmnts %~ (Placement (PSRoomRand 0) (PutCrit spawnerCrit) (const Nothing) :)
|
||||
rmPmnts %~ (spNoID (PSRoomRand 0) (PutCrit spawnerCrit) :)
|
||||
aRoom <- airlock
|
||||
return $ treeFromTrunk [Left aRoom,Left corridor] $ connectRoom roomWithSpawner
|
||||
|
||||
@@ -27,7 +27,7 @@ airlock0 = defaultRoom
|
||||
, _rmLinks = lnks
|
||||
, _rmPath = [(V2 20 95,V2 20 45) ,(V2 20 45,V2 20 5) ]
|
||||
, _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
|
||||
$ Just $ putDoubleDoorThen False col (cond' btid) (V2 (-1) 80) (V2 41 80) 2 Nothing
|
||||
,spanLightI (V2 (-2) 30) (V2 (-2) 70)
|
||||
@@ -49,7 +49,7 @@ airlockSimple = defaultRoom
|
||||
, _rmLinks = lnks
|
||||
, _rmPath = concatMap (doublePair. (V2 90 30,) . fst) lnks
|
||||
, _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)
|
||||
$ sPS (V2 180 0) 0 (PutDoor col (cond btid) inDoorps)
|
||||
]
|
||||
@@ -78,7 +78,7 @@ airlockZ = defaultRoom
|
||||
-- ,(V2 40 0,V2 0 40)
|
||||
-- ]
|
||||
, _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)
|
||||
$ sPS (V2 180 60) 0 (PutDoor col (cond btid) inDoorps)
|
||||
, sps0 $ PutWall (rectNSEW 70 50 120 60) defaultWall
|
||||
@@ -118,7 +118,7 @@ airlock90 = defaultRoom
|
||||
,(V2 40 0,V2 0 40)
|
||||
]
|
||||
, _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
|
||||
,mountLightV (V2 20 20) (V3 70 70 50)
|
||||
]
|
||||
@@ -146,7 +146,7 @@ airlockCrystal = defaultRoom
|
||||
, _rmLinks = [(V2 20 130,0) ,(V2 20 0 ,pi) ]
|
||||
, _rmPath = [ ]
|
||||
, _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
|
||||
, crystalLine (V2 0 70) (V2 40 70)
|
||||
, mountLightV (V2 150 70) (V3 110 70 70)
|
||||
|
||||
@@ -5,12 +5,11 @@ module Dodge.Room.Data
|
||||
import Dodge.LevelGen.Data
|
||||
import Geometry.Data
|
||||
import Data.Tile
|
||||
import Dodge.Data
|
||||
|
||||
import Control.Monad.State
|
||||
import System.Random
|
||||
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.
|
||||
Link pairs contain a position and rotation to attach to another room;
|
||||
@@ -26,16 +25,16 @@ data Room = Room
|
||||
, _rmPos :: [RoomPos]
|
||||
, _rmPath :: [(Point2, Point2)]
|
||||
, _rmPmnts :: [Placement]
|
||||
, _rmTriggers :: IM.IntMap (World -> Bool)
|
||||
, _rmTriggerPmnts :: IM.IntMap ((World -> Bool) -> Placement)
|
||||
, _rmPartialPmnt :: Maybe (Int -> Placement)
|
||||
, _rmExtendedPmnt :: Maybe Placement
|
||||
, _rmBound :: [ [Point2] ]
|
||||
, _rmFloor :: [Tile]
|
||||
, _rmName :: String
|
||||
, _rmShift :: (Point2, Float)
|
||||
, _rmViewpoints :: [Point2]
|
||||
, _rmRandPSs :: [State StdGen (Point2,Float)]
|
||||
, _rmLabel :: Maybe Int
|
||||
, _rmTakeFrom :: Maybe Int
|
||||
, _rmLabel :: Maybe Int
|
||||
, _rmTakeFrom :: Maybe Int
|
||||
}
|
||||
data RoomPos
|
||||
= OutLink Int Point2 Float
|
||||
|
||||
@@ -5,9 +5,9 @@ import Geometry
|
||||
import Dodge.Room.Data
|
||||
import Dodge.Default.Room
|
||||
import Dodge.Placements
|
||||
import Color
|
||||
--import Color
|
||||
|
||||
import qualified Data.IntMap.Strict as IM
|
||||
--import qualified Data.IntMap.Strict as IM
|
||||
|
||||
door :: Room
|
||||
door = defaultRoom
|
||||
@@ -30,8 +30,6 @@ switchDoor = defaultRoom
|
||||
, _rmLinks = lnks
|
||||
, _rmPath = [(V2 20 35,V2 20 5)]
|
||||
-- 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
|
||||
}
|
||||
where
|
||||
|
||||
@@ -39,7 +39,7 @@ twinSlowDoorRoom w h x = defaultRoom
|
||||
]
|
||||
, _rmPath = []
|
||||
, _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)
|
||||
$ 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))
|
||||
|
||||
@@ -175,7 +175,7 @@ fillNothingPlacement :: PSType -> Room -> Room
|
||||
fillNothingPlacement pst r =
|
||||
r & rmPmnts %~ replaceNothingWith pst
|
||||
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 _ [] = []
|
||||
{- | Successively fill 'PutNothing' placements with a list of given 'PSType's.
|
||||
@@ -237,7 +237,7 @@ centerVaultRoom w h d = do
|
||||
where
|
||||
col = dim $ dim $ bright red
|
||||
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)
|
||||
$ sPS (V2 0 (d-10)) 0 (PutSlideDoor False col (cond' btid) (V2 21 0) (V2 0 0) 2)
|
||||
]
|
||||
|
||||
Reference in New Issue
Block a user