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

Working room generation with less shifting, should be more sensible

Browse Source
This commit is contained in:
justin
2021-11-15 01:55:35 +00:00
parent 8356496a7f
commit e93fa10a97
7 changed files with 15 additions and 64 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Layout.hs
+3 -3
View File
@@ -33,7 +33,7 @@ generateLevelFromRoomList gr' w
. placeWires
. doPartialPlacements
. doExtendedPlacements
. flip (mapAccumR doRoomPlacements) rs
. flip (mapAccumR doRoomPlacements) rs'
$ w { _walls = wallsFromRooms rs
, _floorTiles = floorsFromRooms rs
, _gameRooms = gameRoomsFromRooms rs
@@ -43,9 +43,9 @@ generateLevelFromRoomList gr' w
where
path = pairsToGraph dist pairPath
pairPath = concatMap _rmPath rs
rs = zipWith addTile zs gr
zs = map fromIntegral $ randomRs (0,63::Int) $ _randGen w
gr = map doRoomShift gr'
rs = map doRoomShift rs'
rs' = zipWith addTile zs gr'
placeWires :: (World,[Room])-> World
placeWires (w,rms) = foldr placeRoomWires w rms
src/Dodge/Layout/Tree/Shift.hs
+4 -5
View File
@@ -16,11 +16,10 @@ import Data.List (delete)
import Data.Bifunctor
import Control.Lens hiding (Empty, (<|) , (|>))
positionRooms :: Tree RoomInt -> IO (Maybe [Room])
positionRooms (Node (r,i) ts) = posRms (map pointsToPoly $ _rmBound r) (r,i) ts Empty
type RoomInt = (Room,Int)
positionRooms :: Tree RoomInt -> IO (Maybe [Room])
positionRooms (Node (r,i) ts) = posRms (map pointsToPoly $ _rmBound r) (r,i) ts Empty
posRms :: [ConvexPoly]
-> RoomInt
@@ -50,8 +49,8 @@ posRms bounds (r,i) (t@(Node (_,i') _):ts) tseq = do
clipping = or (convexPolysOverlap <$> convexBounds <*> bounds)
newr = (lnkEff l $ r & rmLinks %~ delete l & rmPos %~ (uncurry (OutLink j) l :)
, i)
shiftedt@(Node (r',_) _) = applyToRoot (first $ shiftRoomToLink l) t
shiftedt'@(Node (r'',_) _) = applyToRoot (first $ shiftRoomShiftToLink l) t
(Node (r',_) _) = applyToRoot (first $ shiftRoomToLink l) t
shiftedt' = applyToRoot (first $ shiftRoomShiftToLink l) t
lnkEff :: (Point2,Float) -> Room -> Room
lnkEff x rm = case _rmLinkEff rm of
src/Dodge/LevelGen.hs
+1 -17
View File
@@ -49,11 +49,6 @@ placeSpot (w,rm) plmnt = case plmnt of
where
shift = _rmShift rm
invShiftPSBy :: (Point2,Float) -> PlacementSpot -> PlacementSpot
invShiftPSBy (pos,rot) (PS p r) = PS (invShiftPointBy (pos,rot) p) (r - rot)
invShiftPSBy _ ps = ps
-- this should be tidied up
placeSpotUsingLink :: World -> Room -> Placement
-> (RoomPos -> Maybe PlacementSpot)
@@ -67,7 +62,7 @@ placeSpotUsingLink w rm plmnt extract eff fallback = case searchedPoss (_rmPos r
Just plmnt' -> placeSpot (w,rm) plmnt'
where
searchedPoss [] = error "no correct pos type for lnk placement"
searchedPoss (pos:poss) = case extract (invShiftPosBy (_rmShift rm) pos) of
searchedPoss (pos:poss) = case extract pos of
Nothing -> second (pos:) <$> searchedPoss poss
Just ps -> Just ( ps,pos, poss)
@@ -135,17 +130,6 @@ shiftPointBy (pos,rot) p = pos +.+ rotateV rot p
invShiftPointBy :: (Point2,Float) -> Point2 -> Point2
invShiftPointBy (p1,r) p2 = rotateV (-r) $ p2 -.- p1
invShiftPosBy :: (Point2,Float) -> RoomPos -> RoomPos
invShiftPosBy s rp = case rp of
OutLink i p a -> uncurry (OutLink i) $ invShiftLinkBy s (p,a)
InLink p a -> uncurry (InLink) $ invShiftLinkBy s (p,a)
UnusedLink p a -> uncurry (UnusedLink) $ invShiftLinkBy s (p,a)
PosPl p a -> uncurry (PosPl) $ invShiftLinkBy s (p,a)
LabPos i rp' -> LabPos i $ invShiftPosBy s rp'
invShiftLinkBy :: (Point2,Float) -> (Point2,Float) -> (Point2,Float)
invShiftLinkBy (pos,rot) (p,r) = (invShiftPointBy (pos,rot) p, r - rot)
shiftPoint3By :: (Point2,Float) -> Point3 -> Point3
shiftPoint3By (pos,rot) (V3 x y z) = addZ z $ pos +.+ rotateV rot (V2 x y)
src/Dodge/Placements/Button.hs
+1 -5
View File
@@ -8,15 +8,11 @@ import Dodge.LevelGen.Data
import Dodge.Default
import Dodge.LevelGen.Switch
import Dodge.Placements.LightSource
import Dodge.Placements.Spot
import Data.Maybe
import Control.Lens
externalButton :: Color -> PlacementSpot -> Placement
--externalButton col ps = pContID ps (PutTrigger (const False))
-- $ \trigid -> Just $ pContID ps (PutButton (makeSwitch col col (oneff trigid) (offeff trigid)))
-- (const Nothing)
externalButton col ps = plCont ps (PutTrigger (const False))
$ \tp -> Just $ pContID ps (PutButton (makeSwitch col col (oneff $ trigid tp) (offeff $ trigid tp)))
(const Nothing)
@@ -38,7 +34,7 @@ putLitButtonID col p a subpl = mntLSOn aShape (Just col) ls p'' (addZ 40 p')
putLitButOnPos :: Color -> (RoomPos -> Maybe PlacementSpot) -> (Int -> Maybe Placement) -> Placement
putLitButOnPos col f subpl
= updatePSToLevel 1 (const thePS) $ mntLSOn aShape (Just col) ls 0 (V3 0 (-40) 40)
= plSpot .~ thePS $ mntLSOn aShape (Just col) ls 0 (V3 0 (-40) 40)
$ \plmnt -> let lsid = fromJust $ _plMID plmnt
in jps0 (PutButton (makeButton col (changeLight lsid)) {_btPos = V2 0 (-1), _btRot = pi})
subpl <&> plSpot .~ _plSpot plmnt
src/Dodge/Placements/LightSource.hs
+5 -3
View File
@@ -3,7 +3,6 @@ import Dodge.Data
import Dodge.LightSources.Lamp
import Dodge.LevelGen.Data
import Dodge.Room.Foreground
import Dodge.Placements.Spot
import Geometry
import Geometry.Vector3D
import Dodge.Creature.Inanimate
@@ -13,6 +12,8 @@ import Dodge.RandomHelp
import Color
import Shape
import Control.Lens
-- | mount a light source on a shape
mntLSOn
:: (Point2 -> Point3 -> Shape) -- ^ function describing the mount shape
@@ -80,8 +81,9 @@ mntLS :: (Point2 -> Point3 -> Shape) -> Point2 -> Point3 -> Placement
mntLS shp wallp lampp = mntLSOn shp Nothing defaultLS wallp lampp (const Nothing)
mntLSCond :: (Point2 -> Point3 -> Shape) -> (RoomPos -> Maybe PlacementSpot) -> Placement
mntLSCond shp shift = updatePSToLevel 2 (const $ PSLnk shift (const id) Nothing)
$ mntLS shp 0 (V3 0 (-40) 90)
mntLSCond shp shift = -- updatePSToLevel 1 (const $ PSLnk shift (const id) Nothing) $
mntLS shp 0 (V3 0 (-40) 90)
& plSpot .~ PSLnk shift (const id) Nothing
-- note that this perhaps pushes the vshape light out too far
mntLight :: Point2 -> Point2 -> Placement
src/Dodge/Placements/Spot.hs
-30
View File
@@ -1,30 +0,0 @@
module Dodge.Placements.Spot
( setPS
, setLocalPS
, updatePS
, updatePSToLevel
) where
import Dodge.LevelGen.Data
setPS :: PlacementSpot -> Placement -> Placement
setPS = updatePS . const
-- TODO remove this, use previous placement spots in continued placements
-- instead
updatePSToLevel :: Int -> (PlacementSpot -> PlacementSpot) -> Placement -> Placement
updatePSToLevel 0 _ plmnt = plmnt
updatePSToLevel i f plmnt = case plmnt of
PlacementUsingPos p pl -> PlacementUsingPos p (fmap (updatePSToLevel i 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 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 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)
src/Dodge/Room/Start.hs
+1 -1
View File
@@ -28,7 +28,7 @@ startRoom = do
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))
, mntLS jShape (V2 0 (h/3)) (V3 40 (h/3) 70)
--, 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