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

Separate placement spot from placement type

Browse Source
This commit is contained in:
justin
2021-11-02 21:12:11 +00:00
parent 59f43a3602
commit 0b058674ea
16 changed files with 77 additions and 85 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/LevelGen.hs
+5 -5
View File
@@ -24,12 +24,12 @@ import qualified Data.IntSet as IS
placeSpot :: World -> ((Point2,Float) , Placement) -> World
placeSpot w (shift, plmnt@Placement{}) =
let (i,w') = placeSpotID (shiftPSBy shift (_placementSpot plmnt)) w
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))
shiftPlacement :: (Point2,Float) -> Placement -> Placement
shiftPlacement shift (Placement ps f) = Placement (shiftPSBy shift ps)
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)
(fmap (shiftPlacement shift) f)
@@ -41,8 +41,8 @@ shiftPSBy (pos,rot) ps = ps
-- the Int here allows for passing parameters down to other placements:
-- button ids, etc
placeSpotID :: PlacementSpot -> World -> (Int, World)
placeSpotID ps w = case _psType ps of
placeSpotID :: PlacementSpot -> PSType -> World -> (Int, World)
placeSpotID ps pt w = case pt of
PutProp prop -> placeProp prop p rot w
PutButton bt -> placeBt bt p rot w
PutFlIt itm -> placeFlIt itm p rot w
@@ -50,7 +50,7 @@ placeSpotID ps w = case _psType ps of
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 (set psType evaluatedType ps) (set randGen g w)
RandPS rgen -> placeSpotID ps evaluatedType (set randGen g w)
where
(evaluatedType, g) = runState rgen (_randGen w)
PutDoor col f pss -> placeDoor col f (map (bimap doShift doShift) pss) w
src/Dodge/LevelGen/Data.hs
+8 -8
View File
@@ -31,19 +31,19 @@ data PSType = PutCrit {_unPutCrit :: Creature}
data PlacementSpot = PS
{ _psPos :: Point2
, _psRot :: Float
, _psType :: PSType
}
data Placement = Placement
{ _placementSpot :: PlacementSpot
, _psType :: PSType
, _idPlacement :: Int -> Maybe Placement
}
| PlacementPos Point3 (Point3 -> 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 (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 $ const Nothing
jsps0 :: PSType -> Maybe Placement
jsps0 pst = Just $ sPS (V2 0 0) 0 pst
@@ -52,19 +52,19 @@ 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 $ \_ -> 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 $ \_ -> Just plm
ps0 :: PSType -> (Int -> Maybe Placement) -> Placement
ps0 pst = Placement (PS (V2 0 0) 0 pst)
ps0 pst = Placement (PS (V2 0 0) 0) pst
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
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 (const $ Just plmnt)
makeLenses ''PSType
makeLenses ''PlacementSpot
src/Dodge/Machine/Sensor.hs
+1 -1
View File
@@ -16,7 +16,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)
$ \lsid -> jsps p r $ PutMachine blue (reverse $ square wdth) defaultMachine
{ _mcDraw = sensorSPic
, _mcUpdate = sensorUpdate damF
src/Dodge/Placements/Button.hs
+2 -2
View File
@@ -12,11 +12,11 @@ import Dodge.Placements.LightSource
import Control.Lens
putLitButtonID :: Color -> Point2 -> Float -> (Int -> Maybe Placement) -> Placement
putLitButtonID col p a subpl = mountLightlID ls p'' (addZ 40 p')
putLitButtonID col p a subpl = mountLightAID ls p'' (addZ 40 p')
$ \lsid -> jps0 (PutButton (makeButton col (changeLight lsid)) {_btPos = p, _btRot = a})
subpl
where
p' = p -.- 20 *.* vNormal (unitVectorAtAngle a)
p' = p -.- 30 *.* vNormal (unitVectorAtAngle a)
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 }
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)
-> 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)
@@ -31,7 +31,7 @@ putAutoDoor a b = PlacementPos (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)
$ \btid -> jsps0J (PutSlideDoor False col (cond btid) dra drc 2)
$ sps0 (PutSlideDoor False col (cond btid) drb drc 2)
where
src/Dodge/Placements/LightSource.hs
+26 -24
View File
@@ -72,35 +72,38 @@ mountLightlID = mountLightOnShape f
mountLightll :: Point2 -> Point3 -> Placement
mountLightll = redMID mountLightlID
mountLightAID :: LightSource -> Point2 -> Point3 -> (Int -> Maybe Placement) -> Placement
mountLightAID = mountLightOnShape f
where
f wallpos (V3 x y z) = girder (z+10) 20 10 pout wallpos
where
pout = V2 x y -.- 2 *.* safeNormalizeV (V2 x y -.- wallpos)
mountLightA :: Point2 -> Point3 -> Placement
mountLightA wallpos lamppos@(V3 x y z)
= ps0 (PutLS $ colorLightAt 0.75 lamppos 0)
$ \_ -> jsps0 $ PutForeground $ girder (z+10) 20 10 pout wallpos
where
pout = V2 x y -.- 2 *.* safeNormalizeV (V2 x y -.- wallpos)
mountLightA = redMID mountLightAID
mountColLightI :: Point3 -> Float -> Point2 -> Point2 -> Placement
mountColLightI col h a b = ps0j (PutLS $ colorLightAt col (V3 x y h) 0)
$ sps0 $ PutForeground $ highPipe (h + 5) a b
mountLightVID :: LightSource -> Point2 -> Point3 -> (Int -> Maybe Placement) -> Placement
mountLightVID = mountLightOnShape f
where
V2 x y = 0.5 *.* (a +.+ b)
mountLightI :: Float -> Point2 -> Point2 -> Placement
mountLightI h a b = ps0j (PutLS $ lightAt (V3 x y h) 0)
$ sps0 $ PutForeground $ highPipe (h + 5) a b
where
V2 x y = 0.5 *.* (a +.+ b)
f wallpos (V3 x y z) = thinHighBar (z + 5) wallposUp (lxy `extendAway` wallposUp)
<> thinHighBar (z + 5) wallposDown (lxy `extendAway` wallposDown)
where
lxy = V2 x y
n = vNormal (wallpos -.- lxy)
wallposUp = wallpos +.+ n
wallposDown = wallpos -.- n
mountLightV :: Point2 -> Point3 -> Placement
mountLightV wallpos lamppos@(V3 x y z)
= ps0 (PutLS $ colorLightAt 0.75 lamppos 0)
$ \_ -> jsps0 $ PutForeground $ thinHighBar (z + 5) wallposUp (lxy `extendAway` wallposUp)
<> thinHighBar (z + 5) wallposDown (lxy `extendAway` wallposDown)
mountLightV = redMID mountLightVID
spanColLightI :: Point3 -> Float -> Point2 -> Point2 -> Placement
spanColLightI col h a b = ps0j (PutLS $ colorLightAt col (V3 x y h) 0)
$ sps0 $ PutForeground $ highPipe (h + 5) a b
where
lxy = V2 x y
n = vNormal (wallpos -.- lxy)
wallposUp = wallpos +.+ n
wallposDown = wallpos -.- n
V2 x y = 0.5 *.* (a +.+ b)
spanLightI :: Float -> Point2 -> Point2 -> Placement
spanLightI = spanColLightI 0.75
extendAway :: Point2 -> Point2 -> Point2
extendAway p x = p +.+ safeNormalizeV (p -.- x)
@@ -110,4 +113,3 @@ putColorLamp col = PutCrit (colorLamp col 90)
putLamp :: PSType
putLamp = PutCrit (lamp 90)
src/Dodge/Placements/Wall.hs
+8 -26
View File
@@ -21,33 +21,20 @@ Places a line of blocks between two points.
Width 9, also extends out from each point by 9.
-}
blockLine :: Point2 -> Point2 -> Placement
blockLine a b = Placement PS
{ _psPos = V2 0 0
, _psRot = 0
, _psType = PutLineBlock baseBlockPane 9 9 a b
} (const Nothing)
blockLine a b = sps0 $ PutLineBlock baseBlockPane 9 9 a b
{-
Places an breakable window between two points.
Width 8, also extends out from each point by 8.
-}
windowLine :: Point2 -> Point2 -> Placement
windowLine a b = Placement PS
{ _psPos = V2 0 0
, _psRot = 0
, _psType = PutLineBlock baseWindowPane 8 8 a b
} (const Nothing)
windowLine a b = sps0 $ PutLineBlock baseWindowPane 8 8 a b
{-
Places an unbreakable window between two points.
Width 7, also extends out from each point by 7.
-}
crystalLine :: Point2 -> Point2 -> Placement
crystalLine a b = Placement PS
{ _psPos = V2 0 0
, _psRot = 0
, _psType = PutWall ps defaultCrystalWall
} (const Nothing)
crystalLine a b = sps0 $ PutWall ps defaultCrystalWall
where
ps =
[ a +.+ left +.+ up
@@ -61,14 +48,9 @@ crystalLine a b = Placement PS
Depth 15, does not extend wider than points.
-}
wallLine :: Point2 -> Point2 -> Placement
wallLine a b = Placement PS
{ _psPos = V2 0 0
, _psRot = 0
, _psType = PutWall ps defaultWall
} (const Nothing)
wallLine a b = sps0 $ PutWall ps defaultWall
where
ps =
[ a +.+ up
ps = [ a +.+ up
, a -.- up
, b -.- up
, b +.+ up
@@ -107,14 +89,14 @@ replacePutID
-> Room
-> Room
replacePutID i psts r =
r & rmPS %~ flip (subZipWith (isPutID i) (\ps pt -> ps & placementSpot . psType .~ pt)) psts
r & rmPS %~ flip (subZipWith (isPutID i) (\ps pt -> ps & psType .~ pt)) psts
{- Partition a list by a predicate, apply a zip to those elements
that satisfy the predicate, concatenate
the new zipped list and the other (unchanged) half. -}
subZipWith
:: (a -> Bool) -- ^ Filter: elements to apply zip to
-> (a -> b -> a) -- ^ Combining function
-> [a] -- ^ List to be partition
-> [a] -- ^ List to be partitioned
-> [b] -- ^ Modifying list
-> [a]
subZipWith f g xs ys =
@@ -122,7 +104,7 @@ subZipWith f g xs ys =
in zipWith g zs ys ++ ws
isPutID :: Int -> Placement -> Bool
isPutID i ps = Just i == ps ^? placementSpot . psType . putID
isPutID i ps = Just i == ps ^? psType . putID
putBlockRect :: Float -> Float -> Float -> Float -> [Placement]
putBlockRect a x b y =
src/Dodge/Room.hs
+1 -1
View File
@@ -66,7 +66,7 @@ roomPadCut ps p = defaultRoom
roomPillars :: Room
roomPillars = over rmLinks init $ set rmPS plmnts $ roomRect 240 240 2 2
where
plmnts = mountLightI 70 (V2 120 24) (V2 120 216)
plmnts = spanLightI 70 (V2 120 24) (V2 120 216)
: mountLightV (V2 12 12) (V3 25 25 70)
: mountLightV (V2 228 228) (V3 215 215 70)
: sps0 (PutForeground $ thinHighBar 75 (V2 26 25) (V2 120 25))
src/Dodge/Room/Airlock.hs
+4 -4
View File
@@ -25,10 +25,10 @@ airlock0 = defaultRoom
, _rmLinks = lnks
, _rmPath = [(V2 20 95,V2 20 45) ,(V2 20 45,V2 20 5) ]
, _rmPS =
[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)
$ \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
,mountLightI 70 (V2 (-2) 30) (V2 (-2) 70)
,spanLightI 70 (V2 (-2) 30) (V2 (-2) 70)
,sps0 $ PutForeground $ thinHighBar 75 (V2 40 50) (V2 (-1) 50)
]
, _rmBound = [rectNSWE 75 15 0 40]
@@ -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/Boss.hs
+2 -2
View File
@@ -97,8 +97,8 @@ roomCross x y = defaultRoom
]
, _rmPath = []
, _rmPS =
[ mountLightI 70 (V2 (x+5) x) (V2 (x+5) (-x))
, mountLightI 70 (V2 (-x-5) x) (V2 (-x-5) (-x))
[ spanLightI 70 (V2 (x+5) x) (V2 (x+5) (-x))
, spanLightI 70 (V2 (-x-5) x) (V2 (-x-5) (-x))
]
, _rmBound =
[rectNSWE y (-y) (-x) x
src/Dodge/Room/Corridor.hs
+1 -1
View File
@@ -17,7 +17,7 @@ corridor = defaultRoom
{ _rmPolys = [poly]
, _rmLinks = lnks
, _rmPath = concatMap (doublePair . (,) (V2 20 60) . fst) lnks
, _rmPS = [ mountLightI 50 (V2 0 40) (V2 40 40) ]
, _rmPS = [ spanLightI 50 (V2 0 40) (V2 40 40) ]
, _rmBound = [ rectNSWE 50 30 0 40 ]
, _rmFloor = [makeTileFromPoly poly 2]
}
src/Dodge/Room/Foreground.hs
+11 -3
View File
@@ -110,12 +110,13 @@ girderV h d w x y = colorSH red $ mconcat $
evenDouble (a:_:xs) = a:a:evenDouble xs
evenDouble xs = xs
girder
:: Float -- ^ height
girderCol
:: Color
-> Float -- ^ height
-> Float -- ^ distance between cross bars
-> Float -- ^ width
-> Point2 -> Point2 -> Shape
girder h d w x y = colorSH red $ mconcat $
girderCol col h d w x y = colorSH col $ mconcat $
[ thinHighBar h xt yt
, thinHighBar h xb yb
]
@@ -129,6 +130,13 @@ girder h d w x y = colorSH red $ mconcat $
ps = divideLineExact d xb yb
qs = divideLineExact d xt yt
girder
:: Float -- ^ height
-> Float -- ^ distance between cross bars
-> Float -- ^ width
-> Point2 -> Point2 -> Shape
girder = girderCol red
robotArm :: Shape
robotArm = undefined
src/Dodge/Room/LongDoor.hs
+1 -1
View File
@@ -39,7 +39,7 @@ twinSlowDoorRoom w h x = defaultRoom
]
, _rmPath = []
, _rmPS =
[ Placement (PS (V2 0 (h-5)) pi $ PutButton $ makeButton col id)
[ Placement (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)
$ \did -> jps0 (PutLS (colorLightAt (V3 0.75 0 0) (V3 0 (h-1) lampHeight) 0))
src/Dodge/Room/Procedural.hs
+2 -2
View File
@@ -169,7 +169,7 @@ fillNothingPlacement :: PSType -> Room -> Room
fillNothingPlacement pst r =
r & rmPS %~ 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.
@@ -231,7 +231,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)
$ \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)
]
src/Dodge/Room/RoadBlock.hs
+2 -2
View File
@@ -42,7 +42,7 @@ litCorridor90 = do
]
, _rmPS =
[ sPS (V2 20 (h-5)) 0 putLamp
, mountLightI 70 (V2 0 (0.4*h)) (V2 40 (0.4*h))
, spanLightI 70 (V2 0 (0.4*h)) (V2 40 (0.4*h))
, windowLine (V2 0 (h-20)) (V2 40 (h-20))
, sPS (V2 (-50) (h-85)) 0 putLamp
, windowLine (V2 (-40) (h-60)) (V2 (-40) (h-100))
@@ -75,6 +75,6 @@ blockedCorridor = do
let plmnts =
[sPS (V2 20 40) r $ PutBlock [5,5,5] (V4 (150/256) ( 75/256) 0 ( 250/256))
$ reverse $ rectNSWE 10 (-10) (-10) 10
,mountLightI 55 (V2 0 15) (V2 40 15)
,spanLightI 55 (V2 0 15) (V2 40 15)
]
sequence $ treeFromPost [] $ return $ Right $ set rmPS plmnts corridor
src/Dodge/Room/Start.hs
+1 -1
View File
@@ -21,7 +21,7 @@ import System.Random
rezBox :: Room
rezBox = shiftRoomBy (V2 (-20) (-10),0) $ roomRect 40 20 1 1
& rmPS .~ [ mountColLightI (V3 0 0.7 0.2) 70 (V2 0 10) (V2 40 10) ]
& rmPS .~ [ spanColLightI (V3 0 0.7 0.2) 70 (V2 0 10) (V2 40 10) ]
startRoom :: RandomGen g => State g (Tree (Either Room Room))
startRoom = do