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

Allow for random choice between placements in different rooms

Browse Source
This commit is contained in:
justin
2021-11-26 12:20:20 +00:00
parent aad79bdf25
commit 123bcd2c94
27 changed files with 260 additions and 191 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Data.hs
+1 -1
View File
@@ -110,7 +110,7 @@ data World = World
, _lClickHammer :: HammerPosition
, _distortions :: [Distortion]
, _worldBounds :: Bounds
, _gameRooms :: [GameRoom]
, _gameRooms :: [GameRoom] -- consider using and IntMap
, _keyConfig :: KeyConfigSDL
, _config :: Configuration
, _preloadData :: PreloadData
src/Dodge/Default/Room.hs
+3
View File
@@ -26,4 +26,7 @@ defaultRoom = Room
, _rmStartWires = IM.empty
, _rmEndWires = IM.empty
, _rmConnectsTo = S.singleton OutLink
, _rmMID = Nothing
, _rmMParent = Nothing
, _rmChildren = []
}
src/Dodge/Floor.hs
+21 -56
View File
@@ -1,36 +1,35 @@
{-# OPTIONS_GHC -Wno-unused-imports #-}
--{-# OPTIONS_GHC -Wno-unused-imports #-}
{- | The tree of rooms that make up a level. -}
module Dodge.Floor
( layoutLevelFromSeed
( initialRoomTree
) where
import Geometry.Data
import Dodge.Data
--import Geometry.Data
--import Dodge.Data
import Dodge.LockAndKey
import Dodge.Creature.State.Data
--import Dodge.Creature.State.Data
import Dodge.Room
import Dodge.Placement.Instance.Button
--import Dodge.Placement.Instance.Button
import Dodge.Tree
import Dodge.Annotation
import Dodge.Creature
import Dodge.LevelGen.Data
import Dodge.LevelGen.Switch
import Dodge.Item.Weapon.Launcher
import Dodge.PlacementSpot
import Dodge.RoomPos
import Dodge.Room.RunPast
import MonadHelp
--import Dodge.Creature
--import Dodge.LevelGen.Data
--import Dodge.LevelGen.Switch
--import Dodge.Item.Weapon.Launcher
--import Dodge.PlacementSpot
--import Dodge.RoomPos
--import Dodge.Room.RunPast
--import MonadHelp
import Data.Tree
import Color
import Dodge.Wire
--import Color
--import Dodge.Wire
import Control.Lens
--import Control.Lens
import Control.Monad.State
import Control.Monad.Loops
--import Control.Monad.Loops
import System.Random
import Data.Sequence hiding (zipWith)
import Data.Maybe
import qualified Data.IntMap.Strict as IM
--import Data.Sequence hiding (zipWith)
--import Data.Maybe
--import qualified Data.IntMap.Strict as IM
initialAnoTree :: RandomGen g => Tree [Annotation g]
initialAnoTree = padSucWithCorridors $ treeFromTrunk
@@ -98,38 +97,4 @@ initialRoomTree :: RandomGen g => State g (Tree Room)
initialRoomTree = do
expandTree <$> mapM anoToRoomTree initialAnoTree
layoutLevelFromSeed :: Int -> Int -> IO [Room]
layoutLevelFromSeed i seed = do
let i' = i + 1
putStrLn $ "Generating level with seed " ++ show seed
let g = mkStdGen seed
let rmtree = inorderNumberTree $ evalState initialRoomTree g
putStrLn "Abstract layout: "
putStrLn $ compactDrawTree $ fmap (show . snd) rmtree
mrs <- positionRoomsFromTree rmtree
case mrs of
Just rs -> do
putStrLn $ "After " ++ show i'
++ " attempt(s), Successful generation of level with seed "
++ show seed
--return (fmap setLastLinkToUsed rs)
putStrLn $ show (Prelude.length rs) ++ " rooms in total"
return rs
Nothing -> do
putStr $ "Level generation with seed " ++ show seed ++ " failed: "
let (seed',_) = random g
layoutLevelFromSeed i' seed'
compactDrawTree :: Tree String -> String
compactDrawTree = unlines . compactDraw
compactDraw :: Tree String -> [String]
compactDraw (Node x [Node y ts]) = compactDraw (Node (x++","++y) ts)
compactDraw (Node x ts0) = lines x ++ drawSubTrees ts0
where
drawSubTrees [] = []
drawSubTrees [t] =
"|" : compactDraw t
drawSubTrees (t:ts) =
"|" : shift "+- " "| " (compactDraw t) ++ drawSubTrees ts
shift first other = zipWith (++) (first : repeat other)
src/Dodge/Layout.hs
+42 -18
View File
@@ -15,6 +15,7 @@ import Dodge.GameRoom
import Dodge.Bounds
import Dodge.Default.Wall
import Dodge.Room.Link
import Dodge.Randify
import Geometry
import Geometry.Vector3D
import Geometry.ConvexPoly
@@ -35,35 +36,41 @@ import Data.Maybe
import Data.Function
import Control.Monad.State
generateLevelFromRoomList :: [Room] -> World -> World
generateLevelFromRoomList :: IM.IntMap Room -> World -> World
generateLevelFromRoomList gr' w
= initWallZoning
. setupWorldBounds
. placeWires
. doAfterPlacements
. doPartialPlacements
. doExtendedPlacements
. flip (mapAccumR doRoomPlacements) rs'
. worldToGenWorld
. doIndividualPlacements
-- . flip (mapAccumR doRoomPlacements) (IM.elems rs')
. worldToGenWorld rs'
$ w { _walls = wallsFromRooms rs
, _floorTiles = floorsFromRooms rs
, _gameRooms = gameRoomsFromRooms rs'
, _gameRooms = gameRoomsFromRooms (IM.elems rs')
, _pathGraph = path
, _pathGraphP = pairPath
}
where
path = pairsToGraph dist pairPath
pairPath = concatMap _rmPath rs
zs = map fromIntegral $ randomRs (0,63::Int) $ _randGen w
rs = map doRoomShift rs'
rs' = mapM shuffleRoomPos (zipWith addTile zs gr') & evalState $ _randGen w
rs = map doRoomShift $ IM.elems rs'
rs'= mapM (shuffleRoomPos >=> addRandomTile) gr' & evalState $ _randGen w
addRandomTile :: RandomGen g => Room -> State g Room
addRandomTile r = do
z <- state $ randomR (0,63)
return $ addTile z r
shuffleRoomPos :: RandomGen g => Room -> State g Room
shuffleRoomPos rm = do
newPos <- shuffle $ _rmPos rm
return $ rm & rmPos .~ newPos
placeWires :: (GenWorld,[Room])-> World
placeWires (w,rms) = foldr placeRoomWires (_gWorld w) rms
placeWires :: GenWorld -> World
placeWires w = foldr placeRoomWires (_gWorld w) $ _gRooms w
placeRoomWires :: Room -> World -> World
placeRoomWires rm w = IM.foldr ($) w
@@ -91,8 +98,18 @@ placeWire rm (WallWire p _ h1) (WallWire q _ h2) = foregroundShape
rightpleftq x = isRHS rmcen p x && isLHS rmcen q x
rs = _rmShift rm
doPartialPlacements :: ( (IM.IntMap [Placement],GenWorld) , [Room] ) -> (GenWorld,[Room])
doPartialPlacements ((im,w),rms) = mapAccumR (doPartialPlacement im) w rms
doAfterPlacements :: GenWorld -> GenWorld
doAfterPlacements gw = foldr doAfterPlacement gw (_gPlacements gw)
doAfterPlacement :: [(Placement,Int)] -> GenWorld -> GenWorld
doAfterPlacement pmntis gw = gRandify gw $ do
(pmnt,i) <- takeOne pmntis
let (newgw,rm) = fst $ placeSpot (gw,_gRooms gw IM.! i) pmnt
return $ newgw & gRooms . ix i .~ rm
doPartialPlacements :: ( IM.IntMap [Placement],GenWorld) -> GenWorld
doPartialPlacements (im,w) = let (gw,rms) = mapAccumR (doPartialPlacement im) w (_gRooms w)
in gw {_gRooms = rms}
doPartialPlacement :: IM.IntMap [Placement] -> GenWorld -> Room -> (GenWorld, Room)
doPartialPlacement im w rm = case _rmPartPmnt rm of
@@ -101,8 +118,9 @@ doPartialPlacement im w rm = case _rmPartPmnt rm of
Nothing -> (w, rm)
Just i -> fst $ placeSpot (w,rm) (fi (im IM.! i))
doExtendedPlacements :: (GenWorld,[Room]) -> ( (IM.IntMap [Placement], GenWorld) , [Room] )
doExtendedPlacements (w,rms) = mapAccumR doExtendedPlacement (IM.empty,w) rms
doExtendedPlacements :: GenWorld -> ( IM.IntMap [Placement], GenWorld)
doExtendedPlacements w = let ((pmnts,gw),rms) = mapAccumR doExtendedPlacement (IM.empty,w) (_gRooms w)
in (pmnts,gw{_gRooms = rms})
doExtendedPlacement :: (IM.IntMap [Placement], GenWorld) -> Room
-> ( (IM.IntMap [Placement], GenWorld) , Room )
@@ -113,6 +131,10 @@ doExtendedPlacement (im,w) rm = case _rmExtPmnt rm of
Just i -> let ((neww,newrm),plmnts) = placeSpot (w,rm) plmnt
in ( (IM.insert i plmnts im, neww) , newrm )
doIndividualPlacements :: GenWorld -> GenWorld
doIndividualPlacements gw = let (gw', rms) = mapAccumR doRoomPlacements gw (_gRooms gw)
in gw' {_gRooms = rms}
doRoomPlacements :: GenWorld -> Room -> (GenWorld, Room)
doRoomPlacements w rm = foldl' (\wr -> fst . placeSpot wr) (w,rm) $ _rmPmnts rm
@@ -142,16 +164,18 @@ initWallZoning w = foldl' (flip insertWallInZones) (w & wallsZone . znObjects .~
--makePath = concatMap _rmPath . flatten
wallsFromRooms :: [Room] -> IM.IntMap Wall
wallsFromRooms =
-- divideWalls .
IM.fromList . zipWith f [0..] . removeInverseWalls
. foldl' (flip cutWalls) [] . concatMap _rmPolys
wallsFromRooms = -- divideWalls .
IM.fromAscList
. zipWith f [0..]
. removeInverseWalls
. foldl' (flip cutWalls) []
. concatMap _rmPolys
where
f i (x,y) = (i, defaultWall {_wlLine = (x,y) , _wlID = i})
-- TODO sort out shifting before or after etc
gameRoomsFromRooms :: [Room] -> [GameRoom]
gameRoomsFromRooms = map gameRoomFromRoom
gameRoomsFromRooms = fmap gameRoomFromRoom
gameRoomFromRoom :: Room -> GameRoom
gameRoomFromRoom rm = GameRoom
src/Dodge/LevelGen.hs
+43
View File
@@ -8,10 +8,14 @@ import Dodge.Floor
import Dodge.Layout
import Dodge.Initialisation
import Dodge.RandomHelp
import Dodge.LevelGen.Data
import Dodge.Tree
import Data.Tree
import System.Random
import Control.Lens
import Control.Monad.State
import qualified Data.IntMap.Strict as IM
generateWorldFromSeed :: Int -> IO World
generateWorldFromSeed i = do
@@ -21,3 +25,42 @@ generateWorldFromSeed i = do
randomCompass :: World -> World
randomCompass w = w & cameraRot .~ (takeOne [0,0.5*pi,pi,1.5*pi] & evalState $ _randGen w)
layoutLevelFromSeed :: Int -> Int -> IO (IM.IntMap Room)
layoutLevelFromSeed i seed = do
let i' = i + 1
putStrLn $ "Generating level with seed " ++ show seed
let g = mkStdGen seed
let rmtree = inorderNumberTree $ evalState initialRoomTree g
putStrLn "Abstract layout: "
putStrLn $ compactDrawTree $ fmap (show . snd) rmtree
mrs <- positionRoomsFromTree rmtree
case mrs of
Just rs -> do
putStrLn $ "After " ++ show i'
++ " attempt(s), Successful generation of level with seed "
++ show seed
--return (fmap setLastLinkToUsed rs)
putStrLn $ show (Prelude.length rs) ++ " rooms in total"
return . IM.fromList $ map reversePair rs
Nothing -> do
putStr $ "Level generation with seed " ++ show seed ++ " failed: "
let (seed',_) = random g
layoutLevelFromSeed i' seed'
reversePair :: (a,b) -> (b,a)
reversePair (a,b) = (b,a)
compactDrawTree :: Tree String -> String
compactDrawTree = unlines . compactDraw
compactDraw :: Tree String -> [String]
compactDraw (Node x [Node y ts]) = compactDraw (Node (x++","++y) ts)
compactDraw (Node x ts0) = lines x ++ drawSubTrees ts0
where
drawSubTrees [] = []
drawSubTrees [t] =
"|" : compactDraw t
drawSubTrees (t:ts) =
"|" : shift "+- " "| " (compactDraw t) ++ drawSubTrees ts
shift first other = zipWith (++) (first : repeat other)
src/Dodge/LevelGen/Data.hs
+19 -15
View File
@@ -21,19 +21,18 @@ data PSType = PutCrit {_unPutCrit :: Creature}
| PutButton Button
| PutProp Prop
| PutFlIt Item
| PutPressPlate PressPlate
| PutBlock BlockMaterial [Int] Wall [Point2]
| PutCoordinate Point2
| PutPPlate PressPlate
| PutBlock BlockMaterial Int [Int] Wall [Point2]
| PutCoord Point2
| PutMod Modification
| PutTrigger (World -> Bool)
| PutLineBlock Wall BlockMaterial Float Float Point2 Point2
| PutWall { _pwPoly :: [Point2] , _pwWall :: Wall }
| PutSlideDoor Bool Color (World -> Bool) Point2 Point2 Float
| PutSlideDr Bool Color (World -> Bool) Point2 Point2 Float
| PutDoor Color (World -> Bool) [(Point2,Point2)]
| RandPS (State StdGen PSType)
| PutForeground Shape
| PutShape Shape
| PutWorldUpdate (PlacementSpot -> World -> World)
| AddToPList Int PSType
| PutNothing
| PutID { _putID :: Int}
-- maybe there is a monadic implementation of this?
@@ -49,15 +48,16 @@ data PlacementSpot
{ _psRoomRandPointNum :: Int
, _psRandShift :: (Point2,Float) -> PlacementSpot
}
data Placement = Placement
{ _plSpot :: PlacementSpot
, _plType :: PSType
, _plMID :: Maybe Int
, _plIDCont :: Placement -> Maybe Placement
}
| PlacementUsingPos Point3 (Point3 -> Placement) -- allows a placement to use a shifted position
| RandomPlacement {_unRandomPlacement :: State StdGen Placement}
data Placement
= Placement
{ _plSpot :: PlacementSpot
, _plType :: PSType
, _plMID :: Maybe Int
, _plIDCont :: Placement -> Maybe Placement
}
| PlacementUsingPos Point3 (Point3 -> Placement) -- allows a placement to use a shifted position
| RandomPlacement {_unRandomPlacement :: State StdGen Placement}
| PickOnePlacement Int Placement
{- The '_rmPolys' lists 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;
@@ -89,6 +89,9 @@ data Room = Room
, _rmStartWires :: IM.IntMap RoomWire
, _rmEndWires :: IM.IntMap RoomWire
, _rmConnectsTo :: S.Set RoomLinkType
, _rmMID :: Maybe Int
, _rmMParent :: Maybe Int
, _rmChildren :: [Int]
}
data RoomLink = RoomLink
{ _rlType :: S.Set RoomLinkType
@@ -212,6 +215,7 @@ 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 mi f) -> Placement ps pt mi (fmap g f)
PickOnePlacement {} -> error "not written how to combine PickOnePlacement with others yet"
where
g Nothing = Just pl
g (Just pl') = Just $ addPlmnt pl pl'
src/Dodge/LevelGen/LevelStructure.hs
+8 -2
View File
@@ -12,7 +12,13 @@ import Control.Lens
data GenWorld = GenWorld
{ _gWorld :: World
, _gPlacements :: IM.IntMap [Placement]
, _gPlacements :: IM.IntMap [(Placement,Int)]
, _gRooms :: IM.IntMap Room
}
worldToGenWorld :: IM.IntMap Room -> World -> GenWorld
worldToGenWorld rms w = GenWorld
{ _gWorld = w
, _gPlacements = IM.empty
, _gRooms = rms
}
worldToGenWorld w = GenWorld w IM.empty
makeLenses ''GenWorld
src/Dodge/Placement/Instance/Door.hs
+4 -4
View File
@@ -15,8 +15,8 @@ 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) Nothing $ const mayp
putDoubleDoorThen pathing col cond a b speed mayp = ps0j (PutSlideDr pathing col cond a half speed)
$ Placement (PS (V2 0 0) 0) ( PutSlideDr pathing col cond b half speed) Nothing $ const mayp
where
half = 0.5 *.* (a +.+ b)
@@ -33,8 +33,8 @@ putAutoDoor a b = PlacementUsingPos (addZ 0 a)
switchDoor :: Point2 -> Float -> Point2 -> Point2 -> Color -> Placement
switchDoor btpos btrot dra drb col = pContID (PS btpos btrot) (PutButton $ makeSwitch col red id id)
$ \btid -> jsps0J (PutSlideDoor False col (cond btid) dra drc 2)
$ sps0 (PutSlideDoor False col (cond btid) drb drc 2)
$ \btid -> jsps0J (PutSlideDr False col (cond btid) dra drc 2)
$ sps0 (PutSlideDr False col (cond btid) drb drc 2)
where
drc = 0.5 *.* (dra +.+ drb)
cond btid w' = _btState (_buttons w' IM.! btid) == BtOn
src/Dodge/Placement/Instance/LightSource.hs
+4 -4
View File
@@ -20,7 +20,7 @@ mntLSOn
-> Maybe Color -- ^ describing a possible color override for the shape
-> LightSource -> Point2 -> Point3 -> (Placement -> Maybe Placement) -> Placement
mntLSOn shapeF mcol ls wallp lsp@(V3 lx ly _)
= ps0jPushPS (PutForeground . setCol $ shapeF wallp lsp)
= ps0jPushPS (PutShape . setCol $ shapeF wallp lsp)
. pt0 (PutLS $ ls {_lsPos = lsp'})
where
lsp' = lsp -.-.- V3 x y 1
@@ -106,20 +106,20 @@ unusedLnkToPS rp _ = case rp of
spanLSLightI :: LightSource -> Float -> Point2 -> Point2 -> Placement
spanLSLightI ls h a b = ps0j (PutLS ls {_lsPos = V3 x y h})
$ sps0 $ PutForeground $ thinHighBar h a b
$ sps0 $ PutShape $ thinHighBar h a b
where
V2 x y = 0.5 *.* (a +.+ b)
spanLS :: LightSource -> Point2 -> Point2 -> Placement
spanLS ls a b = Placement (PS (V2 x y) 0) (PutLS ls) Nothing
$ const $ Just $ sps0 $ PutForeground $ thinHighBar h a b
$ const $ Just $ sps0 $ PutShape $ thinHighBar h a b
where
V3 _ _ h = _lsPos ls + 5
V2 x y = 0.5 *.* (a +.+ b)
spanColLightI :: Point3 -> Float -> Point2 -> Point2 -> Placement
spanColLightI col h a b = ps0j (PutLS $ colorLightAt col (V3 x y (h-5)) 0)
$ sps0 $ PutForeground $ thinHighBar h a b
$ sps0 $ PutShape $ thinHighBar h a b
where
V2 x y = 0.5 *.* (a +.+ b)
src/Dodge/Placement/Instance/Tank.hs
+6 -6
View File
@@ -12,7 +12,7 @@ import Color
roundTank :: Color -> Float -> Float -> Placement
roundTank col x y = shiftPlacement (V2 x y,0) $ ps0j
(PutForeground $ colorSH col $
(PutShape $ colorSH col $
upperPrismPoly 31 thecircle
<> foldMap toprail ( take 8 [0,pi/4..])
)
@@ -23,7 +23,7 @@ roundTank col x y = shiftPlacement (V2 x y,0) $ ps0j
roundTankCross :: Color -> Float -> Float -> Placement
roundTankCross col x y = shiftPlacement (V2 x y,0) $ ps0j
(PutForeground $ colorSH col $
(PutShape $ colorSH col $
upperPrismPoly 31 thecircle
<> thinHighBar 31 (V2 20 0) (V2 (-20) 0)
<> thinHighBar 31 (V2 0 20) (V2 0 (-20))
@@ -34,7 +34,7 @@ roundTankCross col x y = shiftPlacement (V2 x y,0) $ ps0j
tankRectCross :: Float -> Float -> Color -> Float -> Float -> Placement
tankRectCross w h col x y = shiftPlacement (V2 x y,0) $ ps0j
(PutForeground $ colorSH col $
(PutShape $ colorSH col $
upperPrismPoly 31 therect
<> thinHighBar 31 (V2 w 0) (V2 (-w) 0)
<> thinHighBar 31 (V2 0 h) (V2 0 (-h))
@@ -49,7 +49,7 @@ tankSquareCross = tankRectCross 20 20
tankRect :: Float -> Float -> Color -> Float -> Float -> Placement
tankRect w h col x y = shiftPlacement (V2 x y,0) $ ps0j
(PutForeground $ colorSH col
(PutShape $ colorSH col
$ upperPrismPoly 31 therect
<> foldMap f [(w',-w',h',h'),(w',-w',-h',-h'),(w',w',h',-h'),(-w',-w',h',-h')]
)
@@ -65,7 +65,7 @@ tankSquare = tankRect 20 20
tankRectEmboss :: Float -> Float -> Color -> Float -> Float -> Placement
tankRectEmboss w h col x y = shiftPlacement (V2 x y,0) $ ps0j
(PutForeground $ colorSH col $
(PutShape $ colorSH col $
upperPrismPoly 31 therect
<> embossingR
<> rotateSH pi embossingR
@@ -84,7 +84,7 @@ tankSquareEmboss = tankRectEmboss 20 20
tankRectEmboss4 :: Float -> Float -> Color -> Float -> Float -> Placement
tankRectEmboss4 w h col x y = shiftPlacement (V2 x y,0) $ ps0j
(PutForeground $ colorSH col $
(PutShape $ colorSH col $
upperPrismPoly 31 therect
<> foldMap f [(w,h),(-w,h),(w,-h),(-w,-h)]
)
src/Dodge/Placement/Instance/Wall.hs
+4 -4
View File
@@ -11,7 +11,7 @@ import Data.List
import Control.Lens
heightWallPS :: PlacementSpot -> Float -> [Point2] -> Placement
heightWallPS spot h ps = psj spot (PutForeground . colorSH col $ upperPrismPoly h ps)
heightWallPS spot h ps = psj spot (PutShape . colorSH col $ upperPrismPoly h ps)
$ sps spot $ PutWall ps theWall
where
col = _wlColor defaultWall
@@ -22,7 +22,7 @@ heightWallPS spot h ps = psj spot (PutForeground . colorSH col $ upperPrismPoly
}
heightWall :: Float -> [Point2] -> Placement
heightWall h ps = ps0j (PutForeground . colorSH col $ upperPrismPoly h ps)
heightWall h ps = ps0j (PutShape . colorSH col $ upperPrismPoly h ps)
$ sps0 $ PutWall ps theWall
where
col = _wlColor defaultWall
@@ -33,7 +33,7 @@ heightWall h ps = ps0j (PutForeground . colorSH col $ upperPrismPoly h ps)
}
midWall :: [Point2] -> Placement
midWall ps = ps0j (PutForeground . colorSH col $ upperPrismPoly 50 ps)
midWall ps = ps0j (PutShape . colorSH col $ upperPrismPoly 50 ps)
$ sps0 $ PutWall ps theWall
where
col = _wlColor defaultWall
@@ -47,7 +47,7 @@ midWall ps = ps0j (PutForeground . colorSH col $ upperPrismPoly 50 ps)
singleBlock :: Point2 -> [Placement]
singleBlock a =
[sPS a 0
$ PutBlock StoneBlock [5,20,20] baseBlockPane
$ PutBlock StoneBlock 5 [20,20] baseBlockPane
$ reverse
$ square 10
]
src/Dodge/Placement/PlaceSpot.hs
+52 -38
View File
@@ -22,6 +22,7 @@ import Shape
import qualified IntMapHelp as IM
import Color
import Data.Maybe
import System.Random
import Control.Monad.State
import Control.Lens
@@ -34,23 +35,34 @@ placeSpot :: (GenWorld,Room) -> Placement -> ( (GenWorld,Room), [Placement] )
placeSpot (w,rm) plmnt = case plmnt of
Placement{_plSpot = PSRoomRand i f} -> placeSpotRoomRand rm i f plmnt w
Placement{_plSpot = PSPos extract eff fallback} -> placeSpotUsingLink w rm plmnt extract eff fallback
Placement{} ->
let (i,w') = placeSpotID (shiftPSBy shift (_plSpot plmnt)) (_plType plmnt) w
newplmnt = plmnt & plMID ?~ i
in maybe ((w',rm),[newplmnt]) (recrPlace newplmnt w') (_plIDCont plmnt newplmnt)
where
recrPlace newplmnt w' pl = let (wr,newplmnts) = placeSpot (w',rm) pl
in (wr,newplmnt:newplmnts)
-- (placeSpot (w',rm)) (_plIDCont plmnt i)
Placement{} -> placePlainPSSpot w rm plmnt shift
PlacementUsingPos p subpl -> placeSpot (w,rm) (subpl (shiftPoint3By shift p))
RandomPlacement rplmnt -> placeSpot (w & gWorld . randGen .~ g,rm) plmnt'
where
(plmnt', g) = runState rplmnt (_randGen $ _gWorld w)
RandomPlacement rplmnt -> placeRandomPlacement rplmnt w rm
PickOnePlacement i pl -> ((placePickOne i pl rm w, rm), [])
where
shift = _rmShift rm
placePickOne :: Int -> Placement -> Room -> GenWorld -> GenWorld
placePickOne i pl rm w = w & gPlacements %~ IM.insertWith (++) i [(pl, fromJust (_rmMID rm))]
placeRandomPlacement :: State StdGen Placement -> GenWorld -> Room -> ((GenWorld,Room),[Placement])
placeRandomPlacement rplmnt w rm = placeSpot (w & gWorld . randGen .~ g,rm) plmnt'
where
(plmnt', g) = runState rplmnt (_randGen $ _gWorld w)
placePlainPSSpot :: GenWorld -> Room -> Placement -> DPoint2 -> ((GenWorld,Room),[Placement])
placePlainPSSpot w rm plmnt shift =
let (i,w') = placeSpotID (shiftPSBy shift (_plSpot plmnt)) (_plType plmnt) w
newplmnt = plmnt & plMID ?~ i
in maybe ((w',rm),[newplmnt]) (recrPlace newplmnt w') (_plIDCont plmnt newplmnt)
where
recrPlace newplmnt w' pl = let (wr,newplmnts) = placeSpot (w',rm) pl
in (wr,newplmnt:newplmnts)
-- this should be tidied up
placeSpotUsingLink :: GenWorld -> Room -> Placement
placeSpotUsingLink :: GenWorld
-> Room
-> Placement
-> (RoomPos -> Room -> Maybe (PlacementSpot,RoomPos))
-> (RoomPos -> Room -> Room)
-> Maybe Placement
@@ -66,44 +78,47 @@ placeSpotUsingLink w rm plmnt extract eff fallback = case searchedPoss (_rmPos r
Nothing -> second (pos:) <$> searchedPoss poss
Just (ps,rmpos) -> Just ( ps,rmpos:poss)
placeSpotRoomRand :: Room -> Int -> ((Point2,Float) -> PlacementSpot)
placeSpotRoomRand :: Room -> Int -> (DPoint2 -> PlacementSpot)
-> Placement -> GenWorld -> ((GenWorld,Room),[Placement])
placeSpotRoomRand rm i f plmnt w =
let (ps,g) = runState (_rmRandPSs rm !! i) $_randGen (_gWorld w)
in placeSpot (w & gWorld . randGen .~ g,rm) (plmnt & plSpot .~ f ps)
-- the Int here is some id that is assigned when the placement is placed
placeSpotID :: PlacementSpot -> PSType -> GenWorld -> (Int, GenWorld)
placeSpotID ps pt w = case pt of
PutTrigger cond -> placeNewInto triggers cond w
PutMod modi -> plNewUpID modifications mdID modi 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 -> 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
PutBlock bm (hp:hps) wl ps' -> placeBlock (map doShift ps') hp wl hps bm w
PutBlock{} -> error "messed up block placement somehow"
PutTrigger cnd -> placeNewInto triggers cnd w
PutMod mdi -> plNewUpID modifications mdID mdi w
PutProp prp -> plNewUpID props pjID (mvProp p rot prp) 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 pps mc -> placeMachine col (map doShift pps) mc p rot w
PutLS ls -> plNewUpID lightSources lsID (mvLS p' rot ls) w
PutPPlate pp -> plNewUpID pressPlates ppID (mvPP p rot pp) w
RandPS rgn -> evaluateRandPS rgn ps w
PutDoor col f pss -> placeDoor col f (map (bimap doShift doShift) pss) w
PutCoord cp -> placeNewInto coordinates (doShift cp) w
PutSlideDr pth col f a b spd
-> placeSlideDoor pth col f (doShift a) (doShift b) spd w
PutBlock bm hp hps wl ps'
-> placeBlock (map doShift ps') hp wl hps bm w
PutLineBlock wl bm wdth dpth a b -> placeLineBlock wl bm wdth dpth (doShift a) (doShift b) w
PutWall { _pwPoly = ps', _pwWall = wl } -> (0,placeWallPoly (map doShift ps') wl w)
PutForeground sh -> (0,w & gWorld . foregroundShape %~ ((uncurryV translateSHf p . rotateSH rot) sh <>))
PutNothing -> (0,w)
PutID i -> (i, w)
PutWorldUpdate f -> (0,w & gWorld %~ f ps)
PutWall qs wl -> (0,placeWallPoly (map doShift qs) wl w)
PutShape sh -> placeShape sh p rot w
PutNothing -> (0,w)
PutID i -> (i, w)
PutWorldUpdate f -> (0,w & gWorld %~ f ps)
where
p@(V2 px py) = _psPos ps
p' = V3 px py 0
rot = _psRot ps
doShift = shiftPointBy (p,rot)
placeShape :: Shape -> Point2 -> Float -> GenWorld -> (Int, GenWorld)
placeShape sh p rot w =
(0, w & gWorld . foregroundShape %~ ((uncurryV translateSHf p . rotateSH rot) sh <>))
evaluateRandPS :: State StdGen PSType -> PlacementSpot -> GenWorld -> (Int,GenWorld)
evaluateRandPS rgen ps w = placeSpotID ps evaluatedType (set (gWorld . randGen) g w)
where
@@ -114,7 +129,6 @@ placeWallPoly ps wl = gWorld %~ (rmCrossPaths . over walls (addWalls ps wl))
where
rmCrossPaths w = foldr (uncurry removePathsCrossing) w $ loopPairs ps
addWalls :: [Point2] -> Wall -> IM.IntMap Wall -> IM.IntMap Wall
addWalls qs wl wls = foldr (addPane wl) wls pairs
where
@@ -134,7 +148,7 @@ placeNewInto :: ALens' World (IM.IntMap a)
-> (Int,GenWorld)
placeNewInto l x w = (i,w & gWorld . l #%~ IM.insert i x)
where
i = IM.newKey $ (_gWorld w) ^# l
i = IM.newKey $ _gWorld w ^# l
-- | place an new object into an intmap and update its id
plNewUpID :: ALens' World (IM.IntMap a)
@@ -144,7 +158,7 @@ plNewUpID :: ALens' World (IM.IntMap a)
-> (Int,GenWorld)
plNewUpID l li x w = (i,w & gWorld . l #%~ IM.insert i (x & li #~ i))
where
i = IM.newKey $ (_gWorld w) ^# l
i = IM.newKey $ _gWorld w ^# l
mvProp :: Point2 -> Float -> Prop -> Prop
mvProp p a = (pjRot +~ a) . (pjPos %~ ( (p +.+) . rotateV a ))
src/Dodge/Placement/PlaceSpot/Block.hs
+1 -1
View File
@@ -73,7 +73,7 @@ placeLineBlock
-> GenWorld
-> (Int, GenWorld)
placeLineBlock basePane bm blockWidth depth a b gw = ( 0
, gw & gWorld .~ (removePathsCrossing a b $ foldr insertWall (insertBlocks w) listWalls)
, gw & gWorld .~ removePathsCrossing a b (foldr insertWall (insertBlocks w) listWalls)
)
where
w = _gWorld gw
src/Dodge/Placement/Shift.hs
+1
View File
@@ -17,3 +17,4 @@ shiftPlacement shift plmnt = case plmnt of
PlacementUsingPos p f -> PlacementUsingPos (shiftPoint3By shift p)
(fmap (shiftPlacement shift) f)
RandomPlacement rpl -> RandomPlacement $ fmap (shiftPlacement shift) rpl
PickOnePlacement i pl -> PickOnePlacement i (shiftPlacement shift pl)
src/Dodge/Randify.hs
+11
View File
@@ -0,0 +1,11 @@
module Dodge.Randify where
import Dodge.Data
import Dodge.LevelGen.LevelStructure
import System.Random
import Control.Monad.State
import Control.Lens
gRandify :: GenWorld -> State StdGen GenWorld -> GenWorld
gRandify gw mw = let (gw',g) = runState mw (_randGen $ _gWorld gw)
in gw' & gWorld . randGen .~ g
src/Dodge/Room/Airlock.hs
+2 -2
View File
@@ -31,7 +31,7 @@ airlock0 = defaultRoom
$ \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)
,sps0 $ PutForeground $ thinHighBar 75 (V2 40 50) (V2 (-1) 50)
,sps0 $ PutShape $ thinHighBar 75 (V2 40 50) (V2 (-1) 50)
]
, _rmBound = [rectNSWE 75 15 0 40]
}
@@ -91,7 +91,7 @@ airlockZ = defaultRoom
inDoorps = (V2 0 0 ,) <$> arcStepwise 3 (pi/2) (V2 0 0) (V2 (-61) 0)
cenlight = mntLS vShape (V2 90 60) (V3 90 40 50) `addPlmnt` mntLS vShape (V2 90 60) (V3 90 80 50)
cornlight = mntLS vShape (V2 0 120) (V3 30 90 50) `addPlmnt` mntLS vShape (V2 180 120) (V3 150 90 50)
`addPlmnt` sps0 (PutForeground (thinHighBar 50 (V2 30 90) (V2 150 90)))
`addPlmnt` sps0 (PutShape (thinHighBar 50 (V2 30 90) (V2 150 90)))
lighting = RandomPlacement $ takeOne [cenlight,cornlight]
airlock90 :: Room
src/Dodge/Room/LasTurret.hs
+2 -2
View File
@@ -36,7 +36,7 @@ cenLasTur = roomNgon 8 200 & rmPmnts .~
lightSensInsideDoor :: Room -> Room
lightSensInsideDoor rm = rm
& rmPmnts %~ ( (psPt atFstLnkOut $ PutForeground $ colorSH yellow $
& rmPmnts %~ ( (psPt atFstLnkOut $ PutShape $ colorSH yellow $
thinHighBar 0 (V2 20 (-1)) (V2 20 (-100))
<> thinHighBar 0 (V2 0 (-100)) (V2 20 (-100))
<> barPP 1.5 (V3 20 (-1) 0) (V3 20 (-1) 80)) : )
@@ -51,7 +51,7 @@ lightSensInsideDoor rm = rm
lightSensByDoor :: Room -> Room
lightSensByDoor rm = rm
& rmPmnts %~ (
[ psPt atFstLnkOut $ PutForeground $ colorSH yellow
[ psPt atFstLnkOut $ PutShape $ colorSH yellow
$ barPP 1.5 (V3 20 (-1) 0) (V3 20 (-1) 80)
, heightWallPS (atNthLnkOutShiftInward 1 100) 30 (rectNSEW 10 (-10) 20 (-20))
, heightWallPS (atFstLnkOutShiftInward 100) 30 (rectNSEW 10 (-10) 20 (-20))
src/Dodge/Room/Link.hs
+1 -1
View File
@@ -20,7 +20,7 @@ module Dodge.Room.Link
, restrictRMInLinksPD
) where
import Dodge.ShiftPoint
import Dodge.Placement.PlaceSpot
--import Dodge.Placement.PlaceSpot
import Dodge.LevelGen.Data
import Dodge.RandomHelp
import Geometry
src/Dodge/Room/LongDoor.hs
+2 -2
View File
@@ -44,8 +44,8 @@ twinSlowDoorRoom w h x = defaultRoom
, _rmPath = []
, _rmPmnts =
[ pContID (PS (V2 0 (h-5)) pi) ( PutButton $ makeButton col id)
$ \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)
$ \btid -> jsps0J (PutSlideDr False col (cond' btid) (V2 x 1) (V2 x h) wlSpeed)
$ ps0 (PutSlideDr 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))
$ \lsid -> jsps0 $ PutProp $ addColorChange lsid did $ lampCoverWhen (drmoving did) (V2 0 (h-1)) lampHeight
]
src/Dodge/Room/Procedural.hs
+4 -4
View File
@@ -49,7 +49,7 @@ roomRect x y xn yn = defaultRoom
{ _rmPolys = [rectNSWE y 0 0 x ]
, _rmLinks = lnks
, _rmPath = concatMap doublePair pth
, _rmPos = map (\p -> UnusedSpot p 0) posps
, _rmPos = map (`UnusedSpot` 0) posps
, _rmPmnts = []
, _rmBound = [rectNSWE (y+5) (-5) (-5) (x+5)]
, _rmFloor = [Tile
@@ -232,7 +232,7 @@ centerVaultRoom w h d = do
,sps0 $ PutWall (rectNSEW d (d - 30) (-d) (30 - d)) defaultWall
,sps0 $ PutWall (rectNSEW (-d) (30 - d) d (d - 30)) defaultWall
,sps0 $ PutWall (rectNSEW (-d) (30 - d) (-d) (30 - d)) defaultWall
,sps0 $ PutForeground $ girder 70 10 10 (V2 (d-11) (-d)) (V2 (d-11) (-h))
,sps0 $ PutShape $ girder 70 10 10 (V2 (d-11) (-d)) (V2 (d-11) (-h))
]
++ map (\a -> mntLS vShape (rotateV a $ V2 0 d) (rotate3z a $ V3 0 (d+30) 70))
[0,0.5*pi,pi,1.5*pi]
@@ -244,7 +244,7 @@ centerVaultRoom w h d = do
col = dim $ dim $ bright red
theDoor =
[ pContID (PS (V2 35 (d+4)) 0) (PutButton $ makeSwitch col red id id)
$ \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)
$ \btid -> jspsJ (V2 0 (d-10)) 0 (PutSlideDr False col (cond' btid) (V2 (-21) 0) (V2 0 0) 2)
$ sPS (V2 0 (d-10)) 0 (PutSlideDr False col (cond' btid) (V2 21 0) (V2 0 0) 2)
]
cond' btid w' = _btState (_buttons w' IM.! btid) == BtOn
src/Dodge/Room/RezBox.hs
+3 -4
View File
@@ -49,7 +49,7 @@ rezBoxesWp = do
let aroom = rezInvBox thecol -- & rmConnectsTo .~ S.singleton (OnEdge North)
let isnorth = S.member (OnEdge North) . _rlType
centralRoom <- shuffleLinks $(roomRectAutoLinks w h) {_rmPmnts = []}
& rmLinks %~ (setLinkType InLink isnorth)
& rmLinks %~ setLinkType InLink isnorth
onwardpassage <- maybeBlockedPassage
let n = length $ getLinksOfType (OnEdge North) $ _rmLinks centralRoom
let rezrooms = map adddoor
@@ -71,8 +71,8 @@ rezBoxesWpCrit = do
theweapon <- randBlockBreakWeapon
--horedge <- takeOne [OnEdge North,OnEdge South]
let centralRoom = (roomRectAutoLinks w h) {_rmPmnts = []}
onwardpassage <- fmap
(applyToCompRoot (rmConnectsTo .~ S.singleton (OnEdge West))) $ maybeBlockedPassage
onwardpassage <-
(applyToCompRoot (rmConnectsTo .~ S.singleton (OnEdge West))) <$> maybeBlockedPassage
let bottomEdgeTest (V2 _ y,_) = y < 1
aroom = rezInvBox thecol
let n = length $ filter bottomEdgeTest $ map lnkPosDir $ _rmLinks centralRoom
@@ -123,7 +123,6 @@ rezBoxes = do
, PassDown door
]
(Node (PassDown centralRoom') (replicate (n-1) dbox ++ [Node (UseAll door) []]))
where
rezColor :: RandomGen g => State g LightSource
src/Dodge/Room/RoadBlock.hs
+1 -1
View File
@@ -74,7 +74,7 @@ blockedCorridor = do
sequence $ treeFromPost [] $ return $ UseAll $ set rmPmnts plmnts corridor
dirtPoly :: [Point2] -> PSType
dirtPoly = PutBlock DirtBlock [1] dirtWall . reverse
dirtPoly = PutBlock DirtBlock 1 [] dirtWall . reverse
-- | A single corridor with a destructible block blocking it.
blockedCorridorCloseBlocks :: RandomGen g => State g Room
src/Dodge/Room/Room.hs
+11 -8
View File
@@ -60,8 +60,8 @@ roomPillars = roomRect 240 240 2 2
plmnts = spanLightI (V2 120 24) (V2 120 216)
: mntLS vShape (V2 12 12) (V3 25 25 70)
: mntLS vShape (V2 228 228) (V3 215 215 70)
: sps0 (PutForeground $ thinHighBar 75 (V2 26 25) (V2 120 25))
: sps0 (PutForeground $ thinHighBar 75 (V2 214 215) (V2 120 215))
: sps0 (PutShape $ thinHighBar 75 (V2 26 25) (V2 120 25))
: sps0 (PutShape $ thinHighBar 75 (V2 214 215) (V2 120 215))
: g 180 150 90 60
f a x b y = putBlockRect a x b y
g a b c d = f a b a b ++ f a b c d ++ f c d a b ++ f c d c d
@@ -150,7 +150,7 @@ miniRoom3 = do
w <- state $ randomR (300,400)
h <- state $ randomR (300,400)
let cp = V2 0 (h/2+40)
let b = PutBlock StoneBlock [5,20,20] baseBlockPane $ map toV2 [(-10,-60)
let b = PutBlock StoneBlock 5 [20,20] baseBlockPane $ map toV2 [(-10,-60)
,( 10,-60)
,( 10,-80)
,(-10,-80)
@@ -273,15 +273,18 @@ weaponEmptyRoom = do
weaponUnderCrits :: RandomGen g => State g (SubCompTree Room)
weaponUnderCrits = do
let plmnts =
[sPS (V2 20 0) 0 $ RandPS randFirstWeapon
,sPS (V2 20 0) (negate $ pi/2) randC1
[--sPS (V2 20 0) 0 $ RandPS randFirstWeapon
sPS (V2 20 0) (negate $ pi/2) randC1
,sPS (V2 20 20) (negate $ pi/2) randC1
]
addwpat p = rmPmnts %~ ((PickOnePlacement 0 $ sPS p 0 $ RandPS randFirstWeapon) :)
let continuationRoom = treeFromTrunk
[PassDown corridorN,PassDown corridorN]
[PassDown $ addwpat (V2 20 0) corridorN,PassDown $ addwpat (V2 20 0) corridorN]
(singleUseAll (set rmPmnts plmnts corridorN))
rcp <- roomCenterPillar
deadEndRoom' <- takeOne [roomPillars,rcp]
deadEndRoom' <- takeOne
[ addwpat (V2 120 20) roomPillars
, addwpat (V2 120 20) rcp]
junctionRoom <- takeOne [PassDown tEast,PassDown tWest]
return $ treeFromTrunk [PassDown corridorN,PassDown corridorN]
$ Node junctionRoom
@@ -313,7 +316,7 @@ weaponBetweenPillars = do
critPlacementSpots <- replicateM 2 $ randDirPS $ unusedSpotAwayFromInLink 100
let plmnts =
sPS wpPos 0 (RandPS randFirstWeapon) :
map (\ps -> sps ps randC1) critPlacementSpots
map (`sps` randC1) critPlacementSpots
theRoom = roomPillars & rmPmnts %~ (++ plmnts)
(fmap singleUseAll . randomiseOutLinks) =<< filterLinks f theRoom
where
src/Dodge/Room/Start.hs
+2 -2
View File
@@ -106,14 +106,14 @@ startRoom' = do
w <- state $ randomR (100,400)
h <- state $ randomR (200,400)
let plmnts =
[ sPS (V2 0 0) 0 $ PutForeground $ girderV 40 20 10 (V2 0 (h/2)) (V2 w (h/2))
[ sPS (V2 0 0) 0 $ PutShape $ girderV 40 20 10 (V2 0 (h/2)) (V2 w (h/2))
--, mntLS jShape (V2 0 (h/3)) (V3 40 (h/3) 70)
, tankSquareEmboss4 (dim orange) 50 (h-60)
, tankSquare (dim orange) 50 50
, tankSquare (dim orange) 50 120
, lightSensor 10 (const id) (PS (V2 (0.8*w) (0.25*h)) 0)
, putLasTurret 0.005 & plSpot .~ PS (V2 (0.8*w) (0.8*h)) 0
, sps0 $ PutForeground $ colorSH orange $ pipePP 2 (V3 50 50 25) (V3 50 120 25)
, sps0 $ PutShape $ colorSH orange $ pipePP 2 (V3 50 50 25) (V3 50 120 25)
]
thecol <- rezColor
treeFromPost [PassDown $ rezBox thecol, PassDown door] . UseAll
src/Dodge/Room/Teleport.hs
+1 -1
View File
@@ -23,7 +23,7 @@ telRoomLev _ = do
w <- state $ randomR (200,300)
h <- state $ randomR (200,300)
return $ roomRectAutoLinks w h & rmPmnts .~
[ sPS (V2 (w/2) (h/2)) 0 $ PutPressPlate telPP
[ sPS (V2 (w/2) (h/2)) 0 $ PutPPlate telPP
, sPS (V2 (w/2) (h/2+ 30)) 0 putLamp
]
where
src/Dodge/Tree/Shift.hs
+8 -5
View File
@@ -21,7 +21,7 @@ import Control.Lens hiding (Empty, (<|) , (|>))
type RoomInt = (Room,Int)
positionRoomsFromTree :: Tree RoomInt -> IO (Maybe [Room])
positionRoomsFromTree :: Tree RoomInt -> IO (Maybe [RoomInt])
positionRoomsFromTree (Node (r,i) ts) = printHeader
>> posRms (map pointsToPoly $ _rmBound r) (r,i) (zipCount ts) Empty
@@ -29,10 +29,10 @@ posRms :: [ConvexPoly]
-> RoomInt
-> [(Int,Tree RoomInt)] -- the list of children, with indices
-> Seq (Tree RoomInt)
-> IO (Maybe [Room])
posRms bounds (parent,_) [] st = case st of
Empty -> return $ Just [parent]
Node childi ts :<| tseq -> fmap (parent:) <$> posRms bounds childi (zipCount ts) tseq
-> IO (Maybe [RoomInt])
posRms bounds (parent,i) [] st = case st of
Empty -> return $ Just [(parent,i)]
Node childi ts :<| tseq -> fmap ((parent,i):) <$> posRms bounds childi (zipCount ts) tseq
posRms bounds parenti@(parent,_) ( (numChild,t@(Node childi _) ):its) tseq = do
printInfoCheckNum parenti numChild childi
tryParentLinks outlinks
@@ -61,9 +61,12 @@ posRms bounds parenti@(parent,_) ( (numChild,t@(Node childi _) ):its) tseq = do
updateparent rm = doLnkEff (lnkPosDir outlnk) $ rm
& rmLinks %~ delete outlnk
& rmPos %~ (uncurry (UsedOutLink numChild (snd childi)) (lnkPosDir outlnk) :)
& rmChildren %~ (snd childi :)
shiftedoutlink = shiftLinkBy (_rmShift parent) outlnk
r' = doRoomShift . fst $ rootLabel shiftedt
updatechild rm = rm
& rmMParent ?~ snd parenti
& rmMID ?~ snd childi
& rmLinks %~ delete il
& rmPos %~ ( (uncurry (UsedInLink 0) (lnkPosDir il):)
. (map (uncurry UnusedLink . lnkPosDir) (delete il (_rmLinks rm)) ++) )
src/Geometry/Data.hs
+3 -10
View File
@@ -1,17 +1,8 @@
module Geometry.Data
( Point2
, Point3
, Point4
( module Geometry.Data
, V2 (..)
, V3 (..)
, V4 (..)
, toV2
, toV3
, toV4
, fromV3
, uncurryV
, fstV2
, sndV2
)
where
import Linear.V2
@@ -21,6 +12,8 @@ type Point2 = V2 Float
type Point3 = V3 Float
type Point4 = V4 Float
type DPoint2 = (Point2,Float)
toV2 :: (a,a) -> V2 a
toV2 (a,b) = V2 a b
toV3 :: (a,a,a) -> V3 a