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

Add lights to buttons, cleanup

Browse Source
This commit is contained in:
justin
2021-11-02 19:38:22 +00:00
parent 9eda8c81a9
commit 59f43a3602
25 changed files with 356 additions and 349 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Data.hs
+2
View File
@@ -59,6 +59,7 @@ data World = World
, _doors :: IM.IntMap Door
, _machines :: IM.IntMap Machine
, _blocks :: IM.IntMap Block
, _coordinates :: IM.IntMap Point2
, _wallsZone :: Zone (IM.IntMap Wall)
, _floorItems :: IM.IntMap FloorItem
, _floorTiles :: [(Point3,Point3)]
@@ -569,6 +570,7 @@ data Door = Door
, _drStatus :: DoorStatus
, _drTrigger :: World -> Bool
, _drMech :: Door -> World -> World
, _drCoord :: Int
}
data DoorStatus = DoorOpen | DoorClosed | DoorHalfway | DoorInt Int
deriving (Eq, Ord, Show)
src/Dodge/Default.hs
+2 -2
View File
@@ -276,8 +276,8 @@ defaultLS = LS
{ _lsID = 0
, _lsPos = 0
, _lsDir = 0
, _lsRad = 4
, _lsIntensity = 0.5
, _lsRad = 700
, _lsIntensity = 0.6
, _lsPict = defLSPic
}
defLSPic :: LightSource -> Picture
src/Dodge/Default/World.hs
+1
View File
@@ -38,6 +38,7 @@ defaultWorld = World
, _blocks = IM.empty
, _machines = IM.empty
, _doors = IM.empty
, _coordinates = IM.empty
, _wallsZone = Zone IM.empty
, _floorItems = IM.empty
, _floorTiles = []
src/Dodge/Floor.hs
+1 -1
View File
@@ -36,7 +36,7 @@ initialRoomTree = do
[[StartRoom]
,[Corridor]
,[Corridor]
,[SpecificRoom slowDoorRoom ]
,[SpecificRoom $ fmap connectRoom slowDoorRoom ]
,[Corridor]
,[Corridor]
,[Corridor]
src/Dodge/Layout.hs
+1 -1
View File
@@ -4,7 +4,7 @@ module Dodge.Layout
import Dodge.Data
import Dodge.LevelGen
import Dodge.LevelGen.StaticWalls
--import Dodge.LevelGen.Data
import Dodge.LevelGen.Pathing
import Dodge.Base
import Dodge.Zone
import Dodge.GameRoom
src/Dodge/LevelGen.hs
+26 -59
View File
@@ -2,18 +2,14 @@
-- | deals with placement of objects within the world
-- after they have had their coordinates set by the layout
module Dodge.LevelGen
( module Dodge.LevelGen
, cutWalls
, pairsToGraph
, makeButton
, makeSwitch
( shiftPlacement
, shiftPointBy
, placeSpot
) where
import Dodge.Data
import Dodge.LevelGen.Block
import Dodge.LevelGen.Pathing
import Dodge.LevelGen.StaticWalls
import Dodge.LevelGen.TriggerDoor
import Dodge.LevelGen.Switch
import Dodge.LevelGen.Data
import Dodge.Default.Wall
import Geometry
@@ -27,13 +23,16 @@ import Control.Lens
import qualified Data.IntSet as IS
placeSpot :: World -> ((Point2,Float) , Placement) -> World
placeSpot w (shift, plmnt) =
placeSpot w (shift, plmnt@Placement{}) =
let (i,w') = placeSpotID (shiftPSBy shift (_placementSpot 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)
(fmap (fmap $ shiftPlacement shift) f)
shiftPlacement shift (PlacementPos p f) = PlacementPos (shiftPoint3By shift p)
(fmap (shiftPlacement shift) f)
shiftPSBy :: (Point2,Float) -> PlacementSpot -> PlacementSpot
shiftPSBy (pos,rot) ps = ps
@@ -54,13 +53,12 @@ placeSpotID ps w = case _psType ps of
RandPS rgen -> placeSpotID (set psType evaluatedType ps) (set randGen g w)
where
(evaluatedType, g) = runState rgen (_randGen w)
PutDoor col f pss -> putDoor col f (map (bimap doShift doShift) pss) w
PutSlideDoor pathing col f a b speed
-> placeSlideDoor pathing col f (doShift a) (doShift b) speed w
PutDoor col f pss -> placeDoor col f (map (bimap doShift doShift) pss) w
PutCoordinate coordp -> placeCoordinate (doShift coordp) w
PutSlideDoor pathing col f a b spd -> placeSlideDoor pathing col f (doShift a) (doShift b) spd w
PutBlock (hp:hps) col ps' -> placeBlock (map doShift ps') hp col Opaque hps w
PutBlock{} -> error "messed up block placement somehow"
PutLineBlock wl width depth a b
-> placeLineBlock wl width depth (doShift a) (doShift b) w
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'
@@ -68,37 +66,18 @@ placeSpotID ps w = case _psType ps of
PutForeground sh -> (0,w & foregroundShape %~ ((uncurryV translateSHf p . rotateSH rot) sh <>))
PutNothing -> (0,w)
PutID i -> (i, w)
--_ -> w
where
p@(V2 px py) = _psPos ps
p' = V3 px py 0
rot = _psRot ps
doShift = shiftPointBy (p,rot)
-- TODO: remove this typeclass
class Shiftable a where
translateS :: Point2 -> a -> a
rotateS :: Float -> a -> a
instance {-# OVERLAPPING #-} Shiftable Point2 where
translateS = (+.+)
rotateS = rotateV
instance (Shiftable a,Shiftable b) => Shiftable (a, b) where
translateS p (x,y) = (translateS p x,translateS p y)
rotateS r (x,y) = ( rotateS r x, rotateS r y)
instance (Shiftable a) => Shiftable [a] where
translateS p x = map (translateS p) x
rotateS r x = map (rotateS r) x
instance Shiftable PlacementSpot where
translateS p' (PS p r x) = PS (p +.+ p') r x
rotateS r' (PS p r x) = PS (rotateV r' p) (r + r') x
shiftPointBy :: (Point2,Float) -> Point2 -> Point2
shiftPointBy (pos,rot) p = pos +.+ rotateV rot p
shiftPoint3By :: (Point2,Float) -> Point3 -> Point3
shiftPoint3By (pos,rot) (V3 x y z) = addZ z $ pos +.+ rotateV rot (V2 x y)
addWalls :: [Point2] -> Wall -> IM.IntMap Wall -> IM.IntMap Wall
addWalls qs wl wls = foldr (addPane wl) wls pairs
where
@@ -106,11 +85,14 @@ addWalls qs wl wls = foldr (addPane wl) wls pairs
pairs = zip (ps ++ [p]) (p:ps)
addPane :: Wall -> (Point2,Point2) -> IM.IntMap Wall -> IM.IntMap Wall
addPane wl (p0,p1) wls = IM.insert (IM.newKey wls) (wl
{ _wlLine = (p0,p1)
, _wlID = IM.newKey wls
})
wls
addPane wl l wls = IM.insert wlid (wl { _wlLine = l, _wlID = wlid }) wls
where
wlid = IM.newKey wls
placeCoordinate :: Point2 -> World -> (Int,World)
placeCoordinate p w = (i, w & coordinates %~ IM.insert i p)
where
i = IM.newKey $ _coordinates w
placeProp
:: Prop
@@ -144,15 +126,9 @@ placeFlIt
-> Float -- ^ Rotation
-> World
-> (Int, World)
placeFlIt itm p rot w = (i, w & floorItems %~
\ fis -> IM.insert i
(FlIt
{ _flItPos = p
, _flItRot = rot
, _flItID = i
, _flIt = itm
}
) fis
placeFlIt itm p rot w = (i, w & floorItems %~ \ fis -> IM.insert i
( FlIt { _flItPos = p , _flItRot = rot , _flItID = i , _flIt = itm }
) fis
)
where
i = IM.newKey $ _floorItems w
@@ -168,12 +144,6 @@ placePressPlate pp p rot w = (i , over pressPlates addPP w)
i = IM.newKey $ _pressPlates w
addPP pps = IM.insert (IM.newKey pps) (pp {_ppPos = p,_ppRot = rot}) pps
placeUpdateCr :: Creature -> Point2 -> Float -> World -> (World, PSType)
placeUpdateCr scr p rot w = (w & creatures %~ IM.insert cid cr, PutCrit cr)
where
cid = IM.newKey (_creatures w)
cr = scr {_crPos = p,_crOldPos = p,_crDir = rot,_crID = cid}
placeCr :: Creature -> Point2 -> Float -> World -> (Int,World)
placeCr crF p rot w = (cid, over creatures addCr w)
where
@@ -204,7 +174,4 @@ placeLS ls (V3 x y z) rot w = (i, over lightSources addLS w)
where
i = IM.newKey $ _lightSources w
startPos = onXY (rotateV rot) $ _lsPos ls
addLS lss = IM.insert
(IM.newKey lss)
(ls {_lsPos = V3 x y z +.+.+ startPos,_lsDir = rot,_lsID = IM.newKey lss})
lss
addLS = IM.insert i (ls {_lsPos = V3 x y z +.+.+ startPos,_lsDir = rot,_lsID = i})
src/Dodge/LevelGen/Block.hs
+8 -10
View File
@@ -75,33 +75,31 @@ placeLineBlock
placeLineBlock basePane blockWidth depth a b w = (,) 0
$ removePathsCrossing a b $ foldr insertWall (insertBlocks w) listWalls
where
d = dist a b
rot = argV (b -.- a)
psOnLine = divideLineOddNumPoints blockWidth a b
halfBlockWidth = d / fromIntegral (length psOnLine - 1)
halfBlockWidth = dist a b / fromIntegral (length psOnLine - 1)
blockCenPs = snd $ evenOddSplit psOnLine
numBlocks = length blockCenPs
is = [0.. numBlocks - 1]
cornerPoints = reverse $ rectWH halfBlockWidth depth -- goes clockwise around the block
cornersAt p = fmap ( (p +.+) . rotateV rot) cornerPoints
cornersAt p = fmap ( (p +.+) . rotateV (argV (b -.- a)) ) cornerPoints
linesAt p = loopPairs $ cornersAt p
k = IM.newKey $ _walls w
wlid = IM.newKey $ _walls w
blid = IM.newKey $ _blocks w
insertBlock i = over blocks $ IM.insert (i+blid) Block
{_blID = i + blid, _blWallIDs = IS.fromList $ ksAtI i, _blHPs = [5,5], _blShadows = shadowsAt i}
insertBlocks = flip (foldr insertBlock) is
ksAtI i = map ( + (k + i*4) ) [0,1,2,3]
ksAtI i = map ( + (wlid + i*4) ) [0,1,2,3]
visibilityAt i
| i == 0 = [ True,True,False,True]
| i == numBlocks - 1 = [False,True, True,True]
| i == 0 = [False,True,True ,True]
| i == numBlocks - 1 = [True ,True,False,True]
| otherwise = [False,True,False,True]
shadowsAt i
| i == 0 = ksAtI 1
| i == numBlocks - 1 = ksAtI $ numBlocks - 2
| otherwise = ksAtI (i-1) ++ ksAtI (i+1)
makeWallAt p i = zipWith3 (makePane i) (visibilityAt i) (ksAtI i) (linesAt p)
makePane i visStatus k' ps = basePane
{_wlID = k'
makePane i visStatus k ps = basePane
{_wlID = k
,_wlStructure = BlockPart $ i + blid
,_wlLine = ps
,_wlDraw = visStatus
src/Dodge/LevelGen/Data.hs
+2
View File
@@ -18,6 +18,7 @@ data PSType = PutCrit {_unPutCrit :: Creature}
| PutFlIt Item
| PutPressPlate PressPlate
| PutBlock [Int] Color [Point2]
| PutCoordinate Point2
| PutLineBlock Wall Float Float Point2 Point2
| PutWall { _pwPoly :: [Point2] , _pwWall :: Wall }
| PutSlideDoor Bool Color (World -> Bool) Point2 Point2 Float
@@ -36,6 +37,7 @@ data Placement = Placement
{ _placementSpot :: PlacementSpot
, _idPlacement :: Int -> Maybe Placement
}
| PlacementPos Point3 (Point3 -> Placement)
sPS :: Point2 -> Float -> PSType -> Placement
sPS p a pt = Placement (PS p a pt) (const Nothing)
src/Dodge/LevelGen/TriggerDoor.hs
+5 -3
View File
@@ -1,6 +1,6 @@
--{-# LANGUAGE BangPatterns #-}
module Dodge.LevelGen.TriggerDoor
( putDoor
( placeDoor
, placeSlideDoor
--, addButtonDoor
) where
@@ -24,14 +24,14 @@ import Data.List
import Control.Lens
--import Data.Graph.Inductive hiding ((&))
import qualified Data.IntSet as IS
putDoor
placeDoor
:: Color
-> (World -> Bool) -- ^ Opening condition
-> [(Point2,Point2)] -- ^ Door positions, closed to open.
-- Bumped out up and down by 9, not widened
-> World
-> (Int,World)
putDoor col cond pss w = (drid, addWalls w & doors %~ addDoor)
placeDoor col cond pss w = (drid, addWalls w & doors %~ addDoor)
where
drid = IM.newKey $ _doors w
addDoor = IM.insert drid $ Door
@@ -40,6 +40,7 @@ putDoor col cond pss w = (drid, addWalls w & doors %~ addDoor)
, _drStatus = DoorInt 0
, _drTrigger = cond
, _drMech = doorMechanismStepwise nsteps drid wlids pss
, _drCoord = 0
}
nsteps = length pss - 1
wlids = take 4 [IM.newKey $ _walls w ..]
@@ -112,6 +113,7 @@ placeSlideDoor isPathable col cond a b speed w = (drid, addWalls w & doors %~ ad
, _drStatus = DoorClosed
, _drTrigger = cond
, _drMech = doorMechanism drid speed (zip3 wlids shiftedPairs pairs)
, _drCoord = 0
}
addWalls w' = foldl' addWall w' $ zip wlids pairs
addWall w' (wlid, wlps) = w' & walls %~ IM.insert wlid defaultWall
src/Dodge/LightSources/Fitting.hs
-80
View File
@@ -1,80 +0,0 @@
module Dodge.LightSources.Fitting
where
import Dodge.LightSources.Lamp
import Dodge.LevelGen.Data
import Dodge.Room.Foreground
import Geometry
mountedLight :: Point2 -> Point3 -> Placement
mountedLight wallPos lampPos@(V3 x y z)
= ps0j (PutForeground $ thinHighBar (z+5) wallPos pout)
$ sps0 $ PutLS (colorLightAt 0.75 lampPos 0)
where
pout = V2 x y +.+ safeNormalizeV (V2 x y -.- wallPos)
mountLightL :: Point2 -> Point3 -> Placement
mountLightL wallpos lamppos@(V3 x y z)
= ps0j (PutLS $ colorLightAt 0.75 lamppos 0)
$ sps0 $ PutForeground $ thinHighBar (z + 5) wallposUp (turnpos `extendAway` wallposUp)
<> thinHighBar (z + 5) turnpos (V2 x y `extendAway` turnpos)
where
n = vNormal (wallpos -.- V2 x y)
wallposUp = wallpos +.+ n
turnpos = V2 x y +.+ n
mountedLightJ :: Point2 -> Point3 -> Placement
mountedLightJ wallpos lamppos@(V3 x y z)
= ps0 (PutLS $ colorLightAt 0.75 lamppos 0)
$ \_ -> jsps0 $ PutForeground $ thinHighBar (z + 5) wallposUp turn1
<> thinHighBar (z + 5) turn1 turn2
<> thinHighBar (z + 5) turn2 (endpos `extendAway` turn2)
where
n = vNormal (wallpos -.- endpos)
wallposUp = wallpos +.+ n
endpos = V2 x y
turnpos = endpos +.+ n
turn1 = 0.5 *.* (wallposUp +.+ turnpos)
turn2 = 0.5 *.* (turnpos +.+ endpos)
wallMountl :: Point2 -> Point3 -> Placement
wallMountl wallpos lamppos@(V3 x y z)
= ps0 (PutLS $ colorLightAt 0.75 lamppos 0)
$ \_ -> jsps0 $ PutForeground $ thinHighBar (z + 5) wallposUp (turnpos `extendAway` wallposUp)
<> thinHighBar (z + 5) turnpos (V2 x y `extendAway` turnpos)
where
n = vNormal (V2 x y -.- wallpos)
wallposUp = wallpos +.+ n
turnpos = V2 x y +.+ n
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)
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
where
V2 x y = 0.5 *.* (a +.+ b)
mountedLightI :: Float -> Point2 -> Point2 -> Placement
mountedLightI 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)
mountedLightV :: Point2 -> Point3 -> Placement
mountedLightV 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)
where
lxy = V2 x y
n = vNormal (wallpos -.- lxy)
wallposUp = wallpos +.+ n
wallposDown = wallpos -.- n
extendAway :: Point2 -> Point2 -> Point2
extendAway p x = p +.+ safeNormalizeV (p -.- x)
src/Dodge/Placements.hs
+8 -26
View File
@@ -1,29 +1,11 @@
module Dodge.Placements
( putDoubleDoor
, putDoubleDoorThen
, putAutoDoor
( module Dodge.Placements.Door
, module Dodge.Placements.LightSource
, module Dodge.Placements.Wall
, module Dodge.Placements.Button
)
where
import Dodge.Data
import Dodge.Base
import Color
import Geometry
import Dodge.LevelGen.Data
import Dodge.Creature.Property
import qualified Data.IntMap.Strict as IM
putDoubleDoor :: Bool -> Color -> (World -> Bool) -> Point2 -> Point2 -> Float -> Placement
putDoubleDoor pathing col cond a b speed = putDoubleDoorThen pathing col cond a b speed Nothing
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
where
half = 0.5 *.* (a +.+ b)
putAutoDoor :: Point2 -> Point2 -> Placement
putAutoDoor a b = putDoubleDoorThen True (dim yellow) cond a b 3 Nothing
where
cond = any (crNearSeg 40 a b) . IM.filter isAnimate . _creatures
import Dodge.Placements.Door
import Dodge.Placements.LightSource
import Dodge.Placements.Wall
import Dodge.Placements.Button
src/Dodge/Placements/Button.hs
+22
View File
@@ -0,0 +1,22 @@
module Dodge.Placements.Button
where
import Dodge.Data
import Color
import Geometry
import Geometry.Vector3D
import Dodge.LevelGen.Data
import Dodge.Default
import Dodge.LevelGen.Switch
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')
$ \lsid -> jps0 (PutButton (makeButton col (changeLight lsid)) {_btPos = p, _btRot = a})
subpl
where
p' = p -.- 20 *.* 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
+39
View File
@@ -0,0 +1,39 @@
module Dodge.Placements.Door
where
import Dodge.Data
import Dodge.Base
import Color
import Geometry
import Geometry.Vector3D
import Dodge.LevelGen.Data
import Dodge.Creature.Property
import Dodge.LevelGen.Switch
import qualified Data.IntMap.Strict as IM
putDoubleDoor :: Bool -> Color -> (World -> Bool) -> Point2 -> Point2 -> Float -> Placement
putDoubleDoor pathing col cond a b speed = putDoubleDoorThen pathing col cond a b speed Nothing
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
where
half = 0.5 *.* (a +.+ b)
putAutoDoor :: Point2 -> Point2 -> Placement
putAutoDoor a b = PlacementPos (addZ 0 a)
$ \az -> PlacementPos (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
switchDoor :: Point2 -> Float -> Point2 -> Point2 -> Color -> Placement
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
drc = 0.5 *.* (dra +.+ drb)
cond btid w' = _btState (_buttons w' IM.! btid) == BtOn
src/Dodge/Placements/LightSource.hs
+113
View File
@@ -0,0 +1,113 @@
module Dodge.Placements.LightSource
where
import Dodge.Data
import Dodge.LightSources.Lamp
import Dodge.LevelGen.Data
import Dodge.Room.Foreground
import Geometry
import Dodge.Creature.Inanimate
import Shape.Data
import Dodge.Default
mountLightOnShape
:: (Point2 -> Point3 -> Shape) -- ^ function describing the mount shape
-> LightSource -> Point2 -> Point3 -> (Int -> Maybe Placement) -> Placement
mountLightOnShape shapeF ls wallp lsp = ps0j (PutForeground $ shapeF wallp lsp)
. ps0 (PutLS $ ls {_lsPos = lsp})
mountLightID :: LightSource -> Point2 -> Point3 -> (Int -> Maybe Placement) -> Placement
mountLightID = mountLightOnShape f
where
f wp (V3 x y z) = thinHighBar (z+5) wp pout
where
pout = V2 x y +.+ safeNormalizeV (V2 x y -.- wp)
redMID :: (LightSource -> Point2 -> Point3 -> (Int -> Maybe Placement) -> Placement)
-> Point2 -> Point3 -> Placement
redMID f wallp lampp = f defaultLS wallp lampp (const Nothing)
mountLight :: Point2 -> Point3 -> Placement
mountLight = redMID mountLightID
mountLightLID :: LightSource -> Point2 -> Point3 -> (Int -> Maybe Placement) -> Placement
mountLightLID = mountLightOnShape f
where
f wallpos (V3 x y z) = thinHighBar (z + 5) wallposUp (turnpos `extendAway` wallposUp)
<> thinHighBar (z + 5) turnpos (V2 x y `extendAway` turnpos)
where
n = vNormal (wallpos -.- V2 x y)
wallposUp = wallpos +.+ n
turnpos = V2 x y +.+ n
mountLightL :: Point2 -> Point3 -> Placement
mountLightL = redMID mountLightLID
mountLightJID :: LightSource -> Point2 -> Point3 -> (Int -> Maybe Placement) -> Placement
mountLightJID = mountLightOnShape f
where
f wallpos (V3 x y z) = thinHighBar (z + 5) wallposUp turn1
<> thinHighBar (z + 5) turn1 turn2
<> thinHighBar (z + 5) turn2 (endpos `extendAway` turn2)
where
n = vNormal (wallpos -.- V2 x y)
wallposUp = wallpos +.+ n
turnpos = V2 x y +.+ n
endpos = V2 x y
turn1 = 0.5 *.* (wallposUp +.+ turnpos)
turn2 = 0.5 *.* (turnpos +.+ endpos)
mountLightJ :: Point2 -> Point3 -> Placement
mountLightJ = redMID mountLightJID
mountLightlID :: LightSource -> Point2 -> Point3 -> (Int -> Maybe Placement) -> Placement
mountLightlID = mountLightOnShape f
where
f wallpos (V3 x y z) = thinHighBar (z + 5) wallposUp (turnpos `extendAway` wallposUp)
<> thinHighBar (z + 5) turnpos (V2 x y `extendAway` turnpos)
where
n = vNormal (V2 x y -.- wallpos)
wallposUp = wallpos +.+ n
turnpos = V2 x y +.+ n
mountLightll :: Point2 -> Point3 -> Placement
mountLightll = redMID mountLightlID
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)
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
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)
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)
where
lxy = V2 x y
n = vNormal (wallpos -.- lxy)
wallposUp = wallpos +.+ n
wallposDown = wallpos -.- n
extendAway :: Point2 -> Point2 -> Point2
extendAway p x = p +.+ safeNormalizeV (p -.- x)
putColorLamp :: Point3 -> PSType
putColorLamp col = PutCrit (colorLamp col 90)
putLamp :: PSType
putLamp = PutCrit (lamp 90)
src/Dodge/Room/Placement.hs → src/Dodge/Placements/Wall.hs
+31 -65
View File
@@ -1,25 +1,14 @@
-- | Module defining helper placements for rooms.
module Dodge.Room.Placement
where
module Dodge.Placements.Wall
where
import Dodge.Data
import Dodge.Default.Wall
import Dodge.LevelGen.Data
import Dodge.LevelGen.Switch
import Dodge.Room.Data
import Dodge.Creature.Inanimate
import Picture
import Color
import Geometry
import Dodge.LevelGen.Data
import Dodge.Default.Wall
import Dodge.Room.Data
import Data.List
import Control.Lens
import qualified Data.IntMap.Strict as IM
putColorLamp :: Point3 -> PSType
putColorLamp col = PutCrit (colorLamp col 90)
putLamp :: PSType
putLamp = PutCrit (lamp 90)
singleBlock :: Point2 -> [Placement]
singleBlock a =
[sPS a 0
@@ -110,6 +99,7 @@ baseWindowPane = defaultWall
, _wlDraw = True
, _wlFireThrough = True
}
-- TODO find home for this
{- Replaces instances of a given 'PutID' with 'PSType's drawn from a list. -}
replacePutID
:: Int -- ^ The id of 'PutID' to be replaced
@@ -134,51 +124,27 @@ subZipWith f g xs ys =
isPutID :: Int -> Placement -> Bool
isPutID i ps = Just i == ps ^? placementSpot . psType . putID
putBlockRect
:: Float
-> Float
-> Float
-> Float
-> [Placement]
putBlockRect a x b y = [ blockLine (V2 a b) (V2 a y)
, blockLine (V2 a y) (V2 x y)
, blockLine (V2 x y) (V2 x b)
, blockLine (V2 x b) (V2 a b)
]
putBlockV
:: Float
-> Float
-> Float
-> Float
-> [Placement]
putBlockV a x b y = [ blockLine (V2 a b) (V2 a y)
, blockLine (V2 x b) (V2 a b)
]
putBlockC
:: Float
-> Float
-> Float
-> Float
-> [Placement]
putBlockC a x b y = [ blockLine (V2 a b) (V2 a y)
, blockLine (V2 x b) (V2 a b)
, blockLine (V2 a y) (V2 x y)
]
putBlockN
:: Float
-> Float
-> Float
-> Float
-> [Placement]
putBlockN a x b y = [ blockLine (V2 a b) (V2 a y)
, blockLine (V2 x b) (V2 a b)
, blockLine (V2 x y) (V2 x b)
]
switchDoor :: Point2 -> Float -> Point2 -> Point2 -> Color -> Placement
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
drc = 0.5 *.* (dra +.+ drb)
cond btid w' = _btState (_buttons w' IM.! btid) == BtOn
putBlockRect :: Float -> Float -> Float -> Float -> [Placement]
putBlockRect a x b y =
[ blockLine (V2 a b) (V2 a y)
, blockLine (V2 a y) (V2 x y)
, blockLine (V2 x y) (V2 x b)
, blockLine (V2 x b) (V2 a b)
]
putBlockV :: Float -> Float -> Float -> Float -> [Placement]
putBlockV a x b y =
[ blockLine (V2 a b) (V2 a y)
, blockLine (V2 x b) (V2 a b)
]
putBlockC :: Float -> Float -> Float -> Float -> [Placement]
putBlockC a x b y =
[ blockLine (V2 a b) (V2 a y)
, blockLine (V2 x b) (V2 a b)
, blockLine (V2 a y) (V2 x y)
]
putBlockN :: Float -> Float -> Float -> Float -> [Placement]
putBlockN a x b y =
[ blockLine (V2 a b) (V2 a y)
, blockLine (V2 x b) (V2 a b)
, blockLine (V2 x y) (V2 x b)
]
src/Dodge/Room.hs
+5 -18
View File
@@ -10,31 +10,20 @@ import Dodge.Item.Weapon.BulletGuns
import Dodge.Item.Weapon.Launcher
import Dodge.Creature
import Dodge.Room.Foreground
--import Dodge.Creature.Inanimate
--import Dodge.LevelGen
import Dodge.LevelGen.Data
--import Dodge.Base
import Dodge.RandomHelp
import Dodge.LevelGen
import Dodge.Default.Wall
--import Dodge.Path
--import Dodge.Layout
import Dodge.Layout.Tree.Polymorphic
import Dodge.Layout.Tree.Either
import Dodge.LightSources.Fitting
--import Dodge.LightSources
--import Dodge.SoundLogic
import Dodge.Placements
import Dodge.Room.Data
import Dodge.Room.Placement
import Dodge.Room.Procedural
import Dodge.Room.Corridor
import Dodge.Room.Link
--import Dodge.Room.Branch
import Dodge.Room.Door
import Dodge.Room.Airlock
import Dodge.Room.LongDoor
import Geometry
--import Geometry.Data
import Picture
import Tile
@@ -44,8 +33,6 @@ import Control.Monad.Loops
import System.Random
import Data.Tree
import Data.Bifunctor
--import qualified Data.Map as M
--import qualified Data.IntMap.Strict as IM
roomC :: Float -> Float -> Room
roomC x y = defaultRoom
@@ -66,7 +53,7 @@ roomC x y = defaultRoom
yn = 4
yd = (y - 40) / fromIntegral yn
xd = (x - 40) / fromIntegral xn
pth = linksAndPath lnks $ translateS (V2 20 20) (makeGrid xd xn yd yn)
pth = linksAndPath lnks $ map (bimap (+.+ V2 20 20) (+.+ V2 20 20)) (makeGrid xd xn yd yn)
roomPadCut :: [Point2] -> Point2 -> Room
roomPadCut ps p = defaultRoom
@@ -79,9 +66,9 @@ roomPadCut ps p = defaultRoom
roomPillars :: Room
roomPillars = over rmLinks init $ set rmPS plmnts $ roomRect 240 240 2 2
where
plmnts = mountedLightI 70 (V2 120 24) (V2 120 216)
: mountedLightV (V2 12 12) (V3 25 25 70)
: mountedLightV (V2 228 228) (V3 215 215 70)
plmnts = mountLightI 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))
: sps0 (PutForeground $ thinHighBar 75 (V2 214 215) (V2 120 215))
: g 180 150 90 60
src/Dodge/Room/Airlock.hs
+4 -6
View File
@@ -2,12 +2,10 @@
{- Rooms that contain two doors and a switch alternating both. -}
module Dodge.Room.Airlock where
import Dodge.Room.Data
import Dodge.LightSources.Fitting
import Dodge.Room.Placement
import Dodge.Placements
import Dodge.Room.Foreground
import Dodge.Default.Room
import Dodge.Data
import Dodge.Placements
import Dodge.LevelGen.Data
import Dodge.LevelGen.Switch
import Dodge.RandomHelp
@@ -30,7 +28,7 @@ airlock0 = defaultRoom
[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
,mountedLightI 70 (V2 (-2) 30) (V2 (-2) 70)
,mountLightI 70 (V2 (-2) 30) (V2 (-2) 70)
,sps0 $ PutForeground $ thinHighBar 75 (V2 40 50) (V2 (-1) 50)
]
, _rmBound = [rectNSWE 75 15 0 40]
@@ -65,7 +63,7 @@ airlock90 = defaultRoom
, _rmPS =
[ 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
,mountedLightV (V2 20 20) (V3 70 70 50)
,mountLightV (V2 20 20) (V3 70 70 50)
]
, _rmBound =
[map toV2 [ (10,10)
@@ -94,7 +92,7 @@ airlockCrystal = defaultRoom
[ 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)
, mountedLightV (V2 150 70) (V3 110 70 70)
, mountLightV (V2 150 70) (V3 110 70 70)
]
, _rmBound =
[ ]
src/Dodge/Room/Boss.hs
+5 -6
View File
@@ -5,10 +5,9 @@ module Dodge.Room.Boss
where
import Dodge.Data
import Dodge.Default.Room
import Dodge.LightSources.Fitting
import Dodge.Placements
import Dodge.Room.Data
import Dodge.Room.Procedural
import Dodge.Room.Placement
import Dodge.Room.Link
import Dodge.Room.Corridor
import Dodge.Room.Path
@@ -98,8 +97,8 @@ roomCross x y = defaultRoom
]
, _rmPath = []
, _rmPS =
[ mountedLightI 70 (V2 (x+5) x) (V2 (x+5) (-x))
, mountedLightI 70 (V2 (-x-5) x) (V2 (-x-5) (-x))
[ mountLightI 70 (V2 (x+5) x) (V2 (x+5) (-x))
, mountLightI 70 (V2 (-x-5) x) (V2 (-x-5) (-x))
]
, _rmBound =
[rectNSWE y (-y) (-x) x
@@ -122,7 +121,7 @@ roomShuriken x y =
{ _rmPolys = ps
, _rmLinks = [(V2 (x-1) (y-20),negate $ pi/2)]
, _rmPath = []
, _rmPS = [mountedLight (V2 x x) (V3 (x-20) x 70)]
, _rmPS = [mountLight (V2 x x) (V3 (x-20) x 70)]
, _rmBound = ps
}
in foldr1 combineRooms $ map (\r -> shiftRoomBy (V2 0 0, r) corner) [0,pi/2,pi,3*pi/2]
@@ -146,7 +145,7 @@ roomTwistCross x y z =
{ _rmPolys = ps
, _rmLinks = [(V2 z (y-20), pi/2)]
, _rmPath = []
, _rmPS = [mountedLight (V2 x x) (V3 (x-20) (x-20) 70)]
, _rmPS = [mountLight (V2 x x) (V3 (x-20) (x-20) 70)]
, _rmBound = ps
}
in foldr1 combineRooms $ map (\r -> shiftRoomBy (V2 0 0, r) corner) [0,pi/2,pi,3*pi/2]
src/Dodge/Room/Corridor.hs
+2 -2
View File
@@ -5,7 +5,7 @@ import Dodge.Room.Data
import Dodge.Default.Room
--import Dodge.LevelGen.Data
--import Dodge.LightSources.Lamp
import Dodge.LightSources.Fitting
import Dodge.Placements
import Geometry
import Tile
@@ -17,7 +17,7 @@ corridor = defaultRoom
{ _rmPolys = [poly]
, _rmLinks = lnks
, _rmPath = concatMap (doublePair . (,) (V2 20 60) . fst) lnks
, _rmPS = [ mountedLightI 50 (V2 0 40) (V2 40 40) ]
, _rmPS = [ mountLightI 50 (V2 0 40) (V2 40 40) ]
, _rmBound = [ rectNSWE 50 30 0 40 ]
, _rmFloor = [makeTileFromPoly poly 2]
}
src/Dodge/Room/LongDoor.hs
+56 -45
View File
@@ -6,24 +6,23 @@ module Dodge.Room.LongDoor
import Dodge.Data
import Dodge.Default.Room
import Dodge.Room.Data
import Dodge.Room.Placement
import Dodge.Placements
import Dodge.Room.Link
import Dodge.Room.Procedural
import Dodge.Layout.Tree.Either
--import Dodge.Layout.Tree.Either
import Dodge.LevelGen.Data
import Dodge.LevelGen.Switch
import Dodge.RandomHelp
import Dodge.Creature.Inanimate
import Dodge.Creature
import Dodge.LightSources.Lamp
import Dodge.Placements
import Picture
import Geometry
import System.Random
import Control.Lens
import Control.Monad.State
import Data.Tree
--import Data.Tree
import qualified Data.IntMap as IM
twinSlowDoorRoom
@@ -76,51 +75,63 @@ twinSlowDoorChasers = do
let plmnts = map (\p -> sPS p 0 $ PutCrit chaseCrit) ps
return $ twinSlowDoorRoom 80 200 40 & rmPS %~ (plmnts ++)
slowDoorRoom :: RandomGen g => State g (Tree (Either Room Room))
slowDoorRoom = do
x <- state $ randomR (400,800)
y <- state $ randomR (400,800)
h <- state $ randomR (200,min (y-100) 500)
(butPos,butRot) <- takeOne
[( V2 (x/2-50) 5,0)
,( V2 (x/2+50) 5,0)
]
let n = 25
xs <- replicateM n $ state $ randomR (10,x-10)
ys <- replicateM n $ state $ randomR (h+20,y)
rs <- replicateM n $ state $ randomR (0,2*pi)
let ps = zipWith V2 xs ys
xs' <- replicateM 5 $ state $ randomR (10,x-10)
ys' <- replicateM 5 $ state $ randomR (h+20,y)
let crits = zipWith (\p r -> sPS p r randC1) ps rs
lsources = [sPS (V2 (x/2) 30) 0 putLamp, sPS (V2 (x/2) (y-30)) 0 putLamp]
barrels = zipWith (\x' y' -> sPS (V2 x' y') 0 $ PutCrit explosiveBarrel) xs' ys'
pillarsa = []
pillarsb = putBlockRect (x/5-20) (x/5+20) (h/2-20) (h/2+20)
++ putBlockRect (2*x/5-20) (2*x/5+20) (h/2-20) (h/2+20)
++ putBlockRect (3*x/5-20) (3*x/5+20) (h/2-20) (h/2+20)
++ putBlockRect (4*x/5-20) (4*x/5+20) (h/2-20) (h/2+20)
pillarsc = putBlockRect (x/3-20) (x/3+20) (h/2-20) (h/2+20)
++ putBlockRect (2*x/3-20) (2*x/3+20) (h/2-20) (h/2+20)
pillars <- takeOne [pillarsa, pillarsb, pillarsc]
let cond x' = (sndV2 . fst) x' > h + 40
cond2 x' = (sndV2 . fst) x' < h - 40
but <- takeOne [butDoor x h butPos butRot
]
fmap connectRoom
(filterLinks cond =<<
changeLinkTo cond2
(set rmPS ([but] ++ crits ++ pillars ++ barrels ++ lsources)
$ roomRectAutoLinks x y
)
)
southPillarsRoom :: RandomGen g => Float -> Float -> Float -> State g Room
southPillarsRoom x y h = do
let pillarsa = []
pillarsb = putBlockRect (x/5-20) (x/5+20) (h/2-20) (h/2+20)
++ putBlockRect (2*x/5-20) (2*x/5+20) (h/2-20) (h/2+20)
++ putBlockRect (3*x/5-20) (3*x/5+20) (h/2-20) (h/2+20)
++ putBlockRect (4*x/5-20) (4*x/5+20) (h/2-20) (h/2+20)
pillarsc = putBlockRect (x/3-20) (x/3+20) (h/2-20) (h/2+20)
++ putBlockRect (2*x/3-20) (2*x/3+20) (h/2-20) (h/2+20)
pillars <- takeOne [pillarsa, pillarsb, pillarsc]
return $ roomRectAutoLinks x y & rmPS .~ pillars
addSouthPillars :: RandomGen g => Float -> Float -> Room -> State g Room
addSouthPillars x h r = do
let pillarsa = []
pillarsb = putBlockRect (x/5-20) (x/5+20) (h/2-20) (h/2+20)
++ putBlockRect (2*x/5-20) (2*x/5+20) (h/2-20) (h/2+20)
++ putBlockRect (3*x/5-20) (3*x/5+20) (h/2-20) (h/2+20)
++ putBlockRect (4*x/5-20) (4*x/5+20) (h/2-20) (h/2+20)
pillarsc = putBlockRect (x/3-20) (x/3+20) (h/2-20) (h/2+20)
++ putBlockRect (2*x/3-20) (2*x/3+20) (h/2-20) (h/2+20)
pillars <- takeOne [pillarsa, pillarsb, pillarsc]
return $ r & rmPS %~ (++ pillars)
addButtonSlowDoor :: RandomGen g => Float -> Float -> Room -> State g Room
addButtonSlowDoor x h rm = do
(butPos,butRot) <- takeOne
[( V2 (x/2-50) 5,0)
,( V2 (x/2+50) 5,0)
]
thePlacement <- takeOne [butDoor butPos butRot ]
filterLinks aboveH =<< changeLinkTo belowH (rm & rmPS %~ (thePlacement :))
where
butDoor x h bpos brot
= ps0 (PutButton $ (makeButton col id) {_btPos = bpos, _btRot = brot})
belowH y = (sndV2 . fst) y < h - 40
aboveH y = (sndV2 . fst) y > h + 40
butDoor bpos brot = putLitButtonID col bpos brot
$ \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
--but <- takeOne [PutBtDoor (dim $ light red) butPos butRot (V2 0 h) (V2 x h) 2
slowDoorRoom :: RandomGen g => State g Room
slowDoorRoom = do
x <- state $ randomR (400,800)
y <- state $ randomR (400,800)
h <- state $ randomR (200,min (y-100) 500)
let n = 25
xs <- replicateM n $ state $ randomR (10,x-10)
ys <- replicateM n $ state $ randomR (h+20,y)
rs <- replicateM n $ state $ randomR (0,2*pi)
let ps = zipWith V2 xs ys
xs' <- replicateM 5 $ state $ randomR (10,x-10)
ys' <- replicateM 5 $ state $ randomR (h+20,y)
let crits = zipWith (\p r -> sPS p r randC1) ps rs
lsources = [sPS (V2 (x/2) 30) 0 putLamp, sPS (V2 (x/2) (y-30)) 0 putLamp]
barrels = zipWith (\x' y' -> sPS (V2 x' y') 0 $ PutCrit explosiveBarrel) xs' ys'
proom <- southPillarsRoom x y h
addButtonSlowDoor x h (proom & rmPS %~ (++ (crits ++ barrels ++ lsources)))
randC1 :: PSType
randC1 = RandPS $ takeOne $ map PutCrit $ armourChaseCrit : replicate 50 chaseCrit
src/Dodge/Room/Procedural.hs
+15 -15
View File
@@ -12,7 +12,7 @@ module Dodge.Room.Procedural
import Dodge.Data
import Dodge.Default.Wall
import Dodge.Room.Data
import Dodge.Room.Placement
import Dodge.Placements
import Dodge.Room.Link
import Dodge.Room.Path
import Dodge.Default.Room
@@ -24,7 +24,7 @@ import Dodge.Item.Weapon.Launcher
import Dodge.RandomHelp
import Dodge.LevelGen
import Dodge.LevelGen.Data
import Dodge.LightSources.Fitting
import Dodge.LevelGen.Switch
import Dodge.Creature
import Geometry
import Geometry.Vector3D
@@ -60,12 +60,12 @@ roomRect x y xn yn = defaultRoom
where
yd = (y - 40) / fromIntegral yn
xd = (x - 40) / fromIntegral xn
elnks = zip (translateS (V2 0 20) $ gridPoints 0 1 yd (yn+1)) (repeat ( pi/2))
wlnks = zip (translateS (V2 x 20) $ gridPoints 0 1 yd (yn+1)) (repeat (-pi/2))
nlnks = zip (translateS (V2 20 y) $ gridPoints xd (xn+1) 0 1 ) (repeat 0 )
slnks = zip (translateS (V2 20 0) $ gridPoints xd (xn+1) 0 1 ) (repeat pi )
elnks = zip (map (+.+ V2 0 20) $ gridPoints 0 1 yd (yn+1)) (repeat ( pi/2))
wlnks = zip (map (+.+ V2 x 20) $ gridPoints 0 1 yd (yn+1)) (repeat (-pi/2))
nlnks = zip (map (+.+ V2 20 y) $ gridPoints xd (xn+1) 0 1 ) (repeat 0 )
slnks = zip (map (+.+ V2 20 0) $ gridPoints xd (xn+1) 0 1 ) (repeat pi )
lnks = nlnks ++ elnks ++ wlnks ++ slnks
pth = linksAndPath lnks $ translateS (V2 20 20) (makeGrid xd xn yd yn)
pth = linksAndPath lnks $ map (bimap (+.+ V2 20 20) (+.+ V2 20 20)) (makeGrid xd xn yd yn)
{- Creates a rectangular room, automatically creates links and pathfinding graph at a sensible size. -}
roomRectAutoLinks :: Float -> Float -> Room
roomRectAutoLinks x y = roomRect x y ((ceiling x - 40) `div` 60) ((ceiling y - 40) `div` 60)
@@ -94,16 +94,16 @@ Add a light and a 'PutNothing' placement. -}
quarterRoomFlat :: RandomGen g => Float -> State g Room
quarterRoomFlat w = do
b <- takeOne
[ [ mountedLightV (V2 0 w) (V3 0 (w-20) 70)
, mountedLight (V2 (w-20) w) (V3 (w-20) (w-20) 70)
[ [ mountLightV (V2 0 w) (V3 0 (w-20) 70)
, mountLight (V2 (w-20) w) (V3 (w-20) (w-20) 70)
, sPS (V2 (w-20) (w-20)) pi PutNothing
, blockLine (V2 (w/2) (w/2)) (V2 (w/2) w)
]
, [ mountedLight (V2 (w-20) w) (V3 (w-20) (w-20) 70)
, [ mountLight (V2 (w-20) w) (V3 (w-20) (w-20) 70)
, sPS (V2 (w-20) (w-20)) pi PutNothing
, blockLine (V2 (w/2) (w/2)) (V2 (negate $ w/2) (w/2))
]
, [ mountedLight (V2 (w-20) w) (V3 (w-20) (w-20) 70)
, [ mountLight (V2 (w-20) w) (V3 (w-20) (w-20) 70)
, sPS (V2 (w-20) (w-20)) pi PutNothing
, blockLine (V2 (w/2) (w/2)) (V2 0 (w/2))
, blockLine (V2 (-29) w) (V2 0 (w/2))
@@ -127,17 +127,17 @@ quarterRoomFlat w = do
fourthCornerWall :: RandomGen g => Float -> State g Room
fourthCornerWall w = do
b <- takeOne
[ [ mountedLightV (V2 0 (2*w-20)) (V3 0 (2*w-40) 70)
[ [ mountLightV (V2 0 (2*w-20)) (V3 0 (2*w-40) 70)
, blockLine (V2 (w/2) (w/2)) (V2 0 w)
, blockLine (V2 (negate $ w/2) (w/2)) (V2 0 w)
, sPS (V2 20 (2*w-40)) pi PutNothing
]
, [ mountedLightV (V2 0 (2*w-20)) (V3 0 (2*w-40) 70)
, [ mountLightV (V2 0 (2*w-20)) (V3 0 (2*w-40) 70)
, blockLine (V2 (w/2) (w/2)) (V2 0 w)
, blockLine (V2 (negate w) w ) (V2 0 w)
, sPS (V2 20 (2*w-40)) pi PutNothing
]
, [ mountedLight (V2 (0.7*w) (1.3*w)) (V3 (0.7*w-20) (1.3*w-20) 70)
, [ mountLight (V2 (0.7*w) (1.3*w)) (V3 (0.7*w-20) (1.3*w-20) 70)
, blockLine (V2 (w/2) (w/2)) (V2 0 w)
, blockLine (V2 0 w) (V2 0 (w*2))
, sPS (V2 20 (2*w-40)) pi PutNothing
@@ -222,7 +222,7 @@ centerVaultRoom w h d = do
,sps0 $ PutWall (rectNSEW (-d) (30 - d) (-d) (30 - d)) defaultWall
,sps0 $ PutForeground $ girder 70 10 10 (V2 (d-11) (-d)) (V2 (d-11) (-h))
]
++ map (\a -> mountedLightV (rotateV a $ V2 0 d) (rotate3z a $ V3 0 (d+30) 70))
++ map (\a -> mountLightV (rotateV a $ V2 0 d) (rotate3z a $ V3 0 (d+30) 70))
[0,0.5*pi,pi,1.5*pi]
++ concatMap (\r -> map (shiftPlacement (V2 0 0,r)) theDoor)
[0,pi/2,pi,3*pi/2]
src/Dodge/Room/RoadBlock.hs
+3 -4
View File
@@ -7,13 +7,12 @@ import Geometry
import Dodge.Default.Room
import Dodge.Room.Data
import Dodge.Room.Link
import Dodge.Room.Placement
import Dodge.Placements
import Dodge.Room.Corridor
import Dodge.LevelGen.Data
--import Dodge.RandomHelp
import Dodge.Creature
import Dodge.Layout.Tree.Polymorphic
import Dodge.LightSources.Fitting
import Data.Tree
import Control.Monad.State
@@ -43,7 +42,7 @@ litCorridor90 = do
]
, _rmPS =
[ sPS (V2 20 (h-5)) 0 putLamp
, mountedLightI 70 (V2 0 (0.4*h)) (V2 40 (0.4*h))
, mountLightI 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))
@@ -76,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
,mountedLightI 55 (V2 0 15) (V2 40 15)
,mountLightI 55 (V2 0 15) (V2 40 15)
]
sequence $ treeFromPost [] $ return $ Right $ set rmPS plmnts corridor
src/Dodge/Room/Start.hs
+2 -2
View File
@@ -6,9 +6,9 @@ import Dodge.Room.Link
import Dodge.Room.Procedural
import Dodge.Room.Foreground
import Dodge.Room.Furniture
import Dodge.Placements
import Dodge.Layout.Tree.Polymorphic
import Dodge.LevelGen.Data
import Dodge.LightSources.Fitting
import Dodge.Machine.Sensor
import Geometry.Data
import Color
@@ -33,7 +33,7 @@ startRoom = do
<$> randomiseOutLinks (shiftRoomBy (V2 (-20) (-20),0)
$ roomRectAutoLinks w h & rmPS .~
[ fground
, mountedLightJ (V2 0 (h/3)) (V3 40 (h/3) 70)
, mountLightJ (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
src/Dodge/Room/Teleport.hs
+1 -1
View File
@@ -5,7 +5,7 @@ import Dodge.Data
import Dodge.Base
import Dodge.Room.Data
import Dodge.Room.Procedural
import Dodge.Room.Placement
import Dodge.Placements
import Dodge.LevelGen.Data
import Geometry
import Picture
src/Dodge/Room/Treasure.hs
+2 -3
View File
@@ -6,10 +6,9 @@ module Dodge.Room.Treasure
where
import Dodge.Data
import Dodge.Room.Data
import Dodge.Room.Placement
import Dodge.Placements
import Dodge.Default.Room
import Dodge.LevelGen.Data
import Dodge.LightSources.Fitting
import Geometry
--import Data.List
@@ -33,7 +32,7 @@ triLootRoom w h = pure $ defaultRoom
[sPS (V2 (15-w) 15 ) 0 $ PutID 0
,sPS (V2 (w-15) 15 ) pi $ PutID 0
,sPS (V2 0 (h-35)) 0 $ PutID 2
,mountedLightV (V2 0 (h-20)) (V3 0 (h-80) 70)
,mountLightV (V2 0 (h-20)) (V3 0 (h-80) 70)
,sPS (V2 0 ( -60)) 0 putLamp
]
, _rmBound = [tri , base]