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

Commit before unifying positions

Browse Source
This commit is contained in:
justin
2021-11-03 19:01:19 +00:00
parent 903a79cf85
commit f45d19a787
7 changed files with 54 additions and 23 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Layout.hs
+23 -6
View File
@@ -3,8 +3,10 @@ module Dodge.Layout
where
import Dodge.Data
import Dodge.LevelGen
import Dodge.LevelGen.Data
import Dodge.LevelGen.StaticWalls
import Dodge.LevelGen.Pathing
import Dodge.Placements.Spot
import Dodge.Base
import Dodge.Zone
import Dodge.GameRoom
@@ -25,7 +27,7 @@ import Tile
import Polyhedra
import Polyhedra.Data
import Data.List (nubBy)
import Data.List (nubBy, partition,mapAccumR)
import Control.Monad.State
import Control.Lens
import System.Random
@@ -50,10 +52,25 @@ generateLevelFromRoomList gr w
where
path = pairsToGraph dist pairPath
pairPath = concatMap _rmPath rs
plmnts = concatMap (\r -> map (_rmShift r ,) (_rmPS r)) rs
rs = zipWith addTile zs rs'
plmnts = concatMap (\r -> map (_rmShift r ,) (assignPlacementSpots r)) rs
rs = zipWith addTile zs . evalState gr $ _randGen w
zs = map fromIntegral $ randomRs (0,63::Int) $ _randGen w
rs' = evalState gr $ _randGen w
assignPlacementSpots :: Room -> [Placement]
assignPlacementSpots rm = plmnts ++ plmnts'
where
(lnkplmnts, plmnts) = partition islnk (_rmPS rm)
islnk Placement{_placementSpot=PSLnk{}} = True
islnk _ = False
(_,plmnts') = mapAccumR f (_rmLinks rm) lnkplmnts
f lnks plmnt =
let (x:xs,ys) = partition (_psLinkTest $ _placementSpot plmnt) lnks
thepair = _psLinkShift (_placementSpot plmnt) x
in (xs++ys, updatePS (updatePSLnkUsing thepair) plmnt)
updatePSLnkUsing :: (Point2,Float) -> PlacementSpot -> PlacementSpot
updatePSLnkUsing pf PSLnk{_psLinkShift=f} = uncurry PS $ f pf
updatePSLnkUsing _ ps = ps
setupWorldBounds :: World -> World
setupWorldBounds w = w
@@ -106,10 +123,10 @@ wallsFromTree t =
wallsFromRooms :: [Room] -> IM.IntMap Wall
wallsFromRooms =
-- divideWalls .
IM.fromList . zip [0..] . zipWith f [0..] . removeInverseWalls
IM.fromList . zipWith f [0..] . removeInverseWalls
. foldl' (flip cutWalls) [] . concatMap _rmPolys
where
f i (x,y) = defaultWall {_wlLine = (x,y) , _wlID = i}
f i (x,y) = (i, defaultWall {_wlLine = (x,y) , _wlID = i})
gameRoomsFromRooms :: [Room] -> [GameRoom]
gameRoomsFromRooms = map f
src/Dodge/LevelGen.hs
+8 -6
View File
@@ -26,12 +26,12 @@ placeSpot :: World -> ((Point2,Float) , Placement) -> World
placeSpot w (shift, plmnt@Placement{}) =
let (i,w') = placeSpotID (shiftPSBy shift (_placementSpot plmnt)) (_psType plmnt) w
in maybe w' (curry (placeSpot w') shift) (_idPlacement plmnt i)
placeSpot w (shift, PlacementPos p subpl) = placeSpot w (shift, subpl (shiftPoint3By shift p))
placeSpot w (shift, PlacementUsingPos p subpl) = placeSpot w (shift, subpl (shiftPoint3By shift p))
shiftPlacement :: (Point2,Float) -> Placement -> Placement
shiftPlacement shift (Placement ps pt f) = Placement (shiftPSBy shift ps) pt
(fmap (fmap $ shiftPlacement shift) f)
shiftPlacement shift (PlacementPos p f) = PlacementPos (shiftPoint3By shift p)
shiftPlacement shift (PlacementUsingPos p f) = PlacementUsingPos (shiftPoint3By shift p)
(fmap (shiftPlacement shift) f)
shiftPSBy :: (Point2,Float) -> PlacementSpot -> PlacementSpot
@@ -59,10 +59,7 @@ placeSpotID ps pt w = case pt of
PutBlock (hp:hps) col ps' -> placeBlock (map doShift ps') hp col Opaque hps w
PutBlock{} -> error "messed up block placement somehow"
PutLineBlock wl wdth dpth a b -> placeLineBlock wl wdth dpth (doShift a) (doShift b) w
PutWall { _pwPoly = ps', _pwWall = wl } -> (0,rmCrossPaths $ over walls (addWalls qs wl) w)
where
qs = map doShift ps'
rmCrossPaths w' = foldr (uncurry removePathsCrossing) w' $ loopPairs qs
PutWall { _pwPoly = ps', _pwWall = wl } -> (0,placeWallPoly (map doShift ps') wl w)
PutForeground sh -> (0,w & foregroundShape %~ ((uncurryV translateSHf p . rotateSH rot) sh <>))
PutNothing -> (0,w)
PutID i -> (i, w)
@@ -72,6 +69,11 @@ placeSpotID ps pt w = case pt of
rot = _psRot ps
doShift = shiftPointBy (p,rot)
placeWallPoly :: [Point2] -> Wall -> World -> World
placeWallPoly ps wl = rmCrossPaths . over walls (addWalls ps wl)
where
rmCrossPaths w = foldr (uncurry removePathsCrossing) w $ loopPairs ps
shiftPointBy :: (Point2,Float) -> Point2 -> Point2
shiftPointBy (pos,rot) p = pos +.+ rotateV rot p
src/Dodge/LevelGen/Data.hs
+7 -6
View File
@@ -28,16 +28,17 @@ data PSType = PutCrit {_unPutCrit :: Creature}
| PutNothing
| PutID { _putID :: Int}
-- maybe there is a monadic implementation of this?
data PlacementSpot = PS
{ _psPos :: Point2
, _psRot :: Float
}
data PlacementSpot
= PS { _psPos :: Point2 , _psRot :: Float }
| PSLnk { _psLinkTest :: (Point2,Float) -> Bool
, _psLinkShift :: (Point2,Float) -> (Point2,Float)
}
data Placement = Placement
{ _placementSpot :: PlacementSpot
, _psType :: PSType
, _idPlacement :: Int -> Maybe Placement
}
| PlacementPos Point3 (Point3 -> Placement)
| PlacementUsingPos Point3 (Point3 -> Placement) -- allows a placement to use a shifted position
sPS :: Point2 -> Float -> PSType -> Placement
sPS p a pt = Placement (PS p a) pt (const Nothing)
@@ -58,7 +59,7 @@ jsps0J :: PSType -> Placement -> Maybe Placement
jsps0J pst plm = Just $ Placement (PS (V2 0 0) 0) pst $ \_ -> Just plm
ps0 :: PSType -> (Int -> Maybe Placement) -> Placement
ps0 pst = Placement (PS (V2 0 0) 0) pst
ps0 = Placement (PS (V2 0 0) 0)
jps0 :: PSType -> (Int -> Maybe Placement) -> Maybe Placement
jps0 pst = Just . Placement (PS (V2 0 0) 0) pst
src/Dodge/Placements/Button.hs
+10
View File
@@ -8,6 +8,7 @@ import Dodge.LevelGen.Data
import Dodge.Default
import Dodge.LevelGen.Switch
import Dodge.Placements.LightSource
import Dodge.Placements.Spot
import Control.Lens
@@ -20,3 +21,12 @@ putLitButtonID col p a subpl = mountLightAID ls p'' (addZ 40 p')
p'' = p +.+ 10 *.* vNormal (unitVectorAtAngle a)
changeLight lsid = lightSources . ix lsid . lsIntensity .~ V3 0 0.5 0
ls = defaultLS { _lsRad = 75 , _lsIntensity = V3 0.5 0 0 }
putLitButtonID' :: Color -> ((Point2,Float) -> Bool) -> (Int -> Maybe Placement) -> Placement
putLitButtonID' col f subpl = setLocalPS thePS $ mountLightAID ls 0 (V3 20 0 40)
$ \lsid -> jps0 (PutButton (makeButton col (changeLight lsid)) {_btPos = 0, _btRot = 0})
subpl
where
changeLight lsid = lightSources . ix lsid . lsIntensity .~ V3 0 0.5 0
ls = defaultLS { _lsRad = 75 , _lsIntensity = V3 0.5 0 0 }
thePS = PSLnk f id
src/Dodge/Placements/Door.hs
+3 -3
View File
@@ -17,15 +17,15 @@ 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) $ const mayp
where
half = 0.5 *.* (a +.+ b)
putAutoDoor :: Point2 -> Point2 -> Placement
putAutoDoor a b = PlacementPos (addZ 0 a)
$ \az -> PlacementPos (addZ 0 b)
putAutoDoor a b = PlacementUsingPos (addZ 0 a)
$ \az -> PlacementUsingPos (addZ 0 b)
$ \bz -> putDoubleDoor True (dim yellow) (cond az bz) a b 3
where
cond az bz = any (crNearSeg 40 (stripZ az) (stripZ bz)) . IM.filter isAnimate . _creatures
src/Dodge/Room/Airlock.hs
+2 -2
View File
@@ -61,7 +61,7 @@ airlock90 = defaultRoom
,(V2 40 0,V2 0 40)
]
, _rmPS =
[ 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)
$ \btid -> jsps (V2 5 5) 0 $ PutDoor col (cond btid) pss
,mountLightV (V2 20 20) (V3 70 70 50)
]
@@ -89,7 +89,7 @@ airlockCrystal = defaultRoom
, _rmLinks = [(V2 20 130,0) ,(V2 20 0 ,pi) ]
, _rmPath = [ ]
, _rmPS =
[ 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)
$ \btid -> jsps0 $ PutDoor col (cond btid) pss
, crystalLine (V2 0 70) (V2 40 70)
, mountLightV (V2 150 70) (V3 110 70 70)
src/Dodge/Room/LongDoor.hs
+1
View File
@@ -115,6 +115,7 @@ addButtonSlowDoor x h rm = do
belowH y = (sndV2 . fst) y < h - 40
aboveH y = (sndV2 . fst) y > h + 40
butDoor bpos brot = putLitButtonID col bpos brot
--butDoor bpos brot = putLitButtonID' col (const True)
$ \btid -> Just $ putDoubleDoor False col (cond' btid) (V2 0 h) (V2 x h) 2
col = dim $ light red
cond' btid w = w ^? buttons . ix btid . btState /= Just BtOff