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 , _doors :: IM.IntMap Door
, _machines :: IM.IntMap Machine , _machines :: IM.IntMap Machine
, _blocks :: IM.IntMap Block , _blocks :: IM.IntMap Block
, _coordinates :: IM.IntMap Point2
, _wallsZone :: Zone (IM.IntMap Wall) , _wallsZone :: Zone (IM.IntMap Wall)
, _floorItems :: IM.IntMap FloorItem , _floorItems :: IM.IntMap FloorItem
, _floorTiles :: [(Point3,Point3)] , _floorTiles :: [(Point3,Point3)]
@@ -569,6 +570,7 @@ data Door = Door
, _drStatus :: DoorStatus , _drStatus :: DoorStatus
, _drTrigger :: World -> Bool , _drTrigger :: World -> Bool
, _drMech :: Door -> World -> World , _drMech :: Door -> World -> World
, _drCoord :: Int
} }
data DoorStatus = DoorOpen | DoorClosed | DoorHalfway | DoorInt Int data DoorStatus = DoorOpen | DoorClosed | DoorHalfway | DoorInt Int
deriving (Eq, Ord, Show) deriving (Eq, Ord, Show)
src/Dodge/Default.hs
+2 -2
View File
@@ -276,8 +276,8 @@ defaultLS = LS
{ _lsID = 0 { _lsID = 0
, _lsPos = 0 , _lsPos = 0
, _lsDir = 0 , _lsDir = 0
, _lsRad = 4 , _lsRad = 700
, _lsIntensity = 0.5 , _lsIntensity = 0.6
, _lsPict = defLSPic , _lsPict = defLSPic
} }
defLSPic :: LightSource -> Picture defLSPic :: LightSource -> Picture
src/Dodge/Default/World.hs
+1
View File
@@ -38,6 +38,7 @@ defaultWorld = World
, _blocks = IM.empty , _blocks = IM.empty
, _machines = IM.empty , _machines = IM.empty
, _doors = IM.empty , _doors = IM.empty
, _coordinates = IM.empty
, _wallsZone = Zone IM.empty , _wallsZone = Zone IM.empty
, _floorItems = IM.empty , _floorItems = IM.empty
, _floorTiles = [] , _floorTiles = []
src/Dodge/Floor.hs
+1 -1
View File
@@ -36,7 +36,7 @@ initialRoomTree = do
[[StartRoom] [[StartRoom]
,[Corridor] ,[Corridor]
,[Corridor] ,[Corridor]
,[SpecificRoom slowDoorRoom ] ,[SpecificRoom $ fmap connectRoom slowDoorRoom ]
,[Corridor] ,[Corridor]
,[Corridor] ,[Corridor]
,[Corridor] ,[Corridor]
src/Dodge/Layout.hs
+1 -1
View File
@@ -4,7 +4,7 @@ module Dodge.Layout
import Dodge.Data import Dodge.Data
import Dodge.LevelGen import Dodge.LevelGen
import Dodge.LevelGen.StaticWalls import Dodge.LevelGen.StaticWalls
--import Dodge.LevelGen.Data import Dodge.LevelGen.Pathing
import Dodge.Base import Dodge.Base
import Dodge.Zone import Dodge.Zone
import Dodge.GameRoom import Dodge.GameRoom
src/Dodge/LevelGen.hs
+25 -58
View File
@@ -2,18 +2,14 @@
-- | deals with placement of objects within the world -- | deals with placement of objects within the world
-- after they have had their coordinates set by the layout -- after they have had their coordinates set by the layout
module Dodge.LevelGen module Dodge.LevelGen
( module Dodge.LevelGen ( shiftPlacement
, cutWalls , shiftPointBy
, pairsToGraph , placeSpot
, makeButton
, makeSwitch
) where ) where
import Dodge.Data import Dodge.Data
import Dodge.LevelGen.Block import Dodge.LevelGen.Block
import Dodge.LevelGen.Pathing import Dodge.LevelGen.Pathing
import Dodge.LevelGen.StaticWalls
import Dodge.LevelGen.TriggerDoor import Dodge.LevelGen.TriggerDoor
import Dodge.LevelGen.Switch
import Dodge.LevelGen.Data import Dodge.LevelGen.Data
import Dodge.Default.Wall import Dodge.Default.Wall
import Geometry import Geometry
@@ -27,13 +23,16 @@ import Control.Lens
import qualified Data.IntSet as IS import qualified Data.IntSet as IS
placeSpot :: World -> ((Point2,Float) , Placement) -> World placeSpot :: World -> ((Point2,Float) , Placement) -> World
placeSpot w (shift, plmnt) = placeSpot w (shift, plmnt@Placement{}) =
let (i,w') = placeSpotID (shiftPSBy shift (_placementSpot plmnt)) w let (i,w') = placeSpotID (shiftPSBy shift (_placementSpot plmnt)) w
in maybe w' (curry (placeSpot w') shift) (_idPlacement plmnt i) 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 :: (Point2,Float) -> Placement -> Placement
shiftPlacement shift (Placement ps f) = Placement (shiftPSBy shift ps) shiftPlacement shift (Placement ps f) = Placement (shiftPSBy shift ps)
(fmap (fmap $ shiftPlacement shift) f) (fmap (fmap $ shiftPlacement shift) f)
shiftPlacement shift (PlacementPos p f) = PlacementPos (shiftPoint3By shift p)
(fmap (shiftPlacement shift) f)
shiftPSBy :: (Point2,Float) -> PlacementSpot -> PlacementSpot shiftPSBy :: (Point2,Float) -> PlacementSpot -> PlacementSpot
shiftPSBy (pos,rot) ps = ps 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) RandPS rgen -> placeSpotID (set psType evaluatedType ps) (set randGen g w)
where where
(evaluatedType, g) = runState rgen (_randGen w) (evaluatedType, g) = runState rgen (_randGen w)
PutDoor col f pss -> putDoor col f (map (bimap doShift doShift) pss) w PutDoor col f pss -> placeDoor col f (map (bimap doShift doShift) pss) w
PutSlideDoor pathing col f a b speed PutCoordinate coordp -> placeCoordinate (doShift coordp) w
-> placeSlideDoor pathing col f (doShift a) (doShift b) speed 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 (hp:hps) col ps' -> placeBlock (map doShift ps') hp col Opaque hps w
PutBlock{} -> error "messed up block placement somehow" PutBlock{} -> error "messed up block placement somehow"
PutLineBlock wl width depth a b PutLineBlock wl wdth dpth a b -> placeLineBlock wl wdth dpth (doShift a) (doShift b) w
-> placeLineBlock wl width depth (doShift a) (doShift b) w
PutWall { _pwPoly = ps', _pwWall = wl } -> (0,rmCrossPaths $ over walls (addWalls qs wl) w) PutWall { _pwPoly = ps', _pwWall = wl } -> (0,rmCrossPaths $ over walls (addWalls qs wl) w)
where where
qs = map doShift ps' 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 <>)) PutForeground sh -> (0,w & foregroundShape %~ ((uncurryV translateSHf p . rotateSH rot) sh <>))
PutNothing -> (0,w) PutNothing -> (0,w)
PutID i -> (i, w) PutID i -> (i, w)
--_ -> w
where where
p@(V2 px py) = _psPos ps p@(V2 px py) = _psPos ps
p' = V3 px py 0 p' = V3 px py 0
rot = _psRot ps rot = _psRot ps
doShift = shiftPointBy (p,rot) 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 :: (Point2,Float) -> Point2 -> Point2
shiftPointBy (pos,rot) p = pos +.+ rotateV rot p 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 :: [Point2] -> Wall -> IM.IntMap Wall -> IM.IntMap Wall
addWalls qs wl wls = foldr (addPane wl) wls pairs addWalls qs wl wls = foldr (addPane wl) wls pairs
where where
@@ -106,11 +85,14 @@ addWalls qs wl wls = foldr (addPane wl) wls pairs
pairs = zip (ps ++ [p]) (p:ps) pairs = zip (ps ++ [p]) (p:ps)
addPane :: Wall -> (Point2,Point2) -> IM.IntMap Wall -> IM.IntMap Wall addPane :: Wall -> (Point2,Point2) -> IM.IntMap Wall -> IM.IntMap Wall
addPane wl (p0,p1) wls = IM.insert (IM.newKey wls) (wl addPane wl l wls = IM.insert wlid (wl { _wlLine = l, _wlID = wlid }) wls
{ _wlLine = (p0,p1) where
, _wlID = IM.newKey wls wlid = IM.newKey wls
})
wls placeCoordinate :: Point2 -> World -> (Int,World)
placeCoordinate p w = (i, w & coordinates %~ IM.insert i p)
where
i = IM.newKey $ _coordinates w
placeProp placeProp
:: Prop :: Prop
@@ -144,14 +126,8 @@ placeFlIt
-> Float -- ^ Rotation -> Float -- ^ Rotation
-> World -> World
-> (Int, World) -> (Int, World)
placeFlIt itm p rot w = (i, w & floorItems %~ placeFlIt itm p rot w = (i, w & floorItems %~ \ fis -> IM.insert i
\ fis -> IM.insert i ( FlIt { _flItPos = p , _flItRot = rot , _flItID = i , _flIt = itm }
(FlIt
{ _flItPos = p
, _flItRot = rot
, _flItID = i
, _flIt = itm
}
) fis ) fis
) )
where where
@@ -168,12 +144,6 @@ placePressPlate pp p rot w = (i , over pressPlates addPP w)
i = IM.newKey $ _pressPlates w i = IM.newKey $ _pressPlates w
addPP pps = IM.insert (IM.newKey pps) (pp {_ppPos = p,_ppRot = rot}) pps 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 :: Creature -> Point2 -> Float -> World -> (Int,World)
placeCr crF p rot w = (cid, over creatures addCr w) placeCr crF p rot w = (cid, over creatures addCr w)
where where
@@ -204,7 +174,4 @@ placeLS ls (V3 x y z) rot w = (i, over lightSources addLS w)
where where
i = IM.newKey $ _lightSources w i = IM.newKey $ _lightSources w
startPos = onXY (rotateV rot) $ _lsPos ls startPos = onXY (rotateV rot) $ _lsPos ls
addLS lss = IM.insert addLS = IM.insert i (ls {_lsPos = V3 x y z +.+.+ startPos,_lsDir = rot,_lsID = i})
(IM.newKey lss)
(ls {_lsPos = V3 x y z +.+.+ startPos,_lsDir = rot,_lsID = IM.newKey lss})
lss
src/Dodge/LevelGen/Block.hs
+8 -10
View File
@@ -75,33 +75,31 @@ placeLineBlock
placeLineBlock basePane blockWidth depth a b w = (,) 0 placeLineBlock basePane blockWidth depth a b w = (,) 0
$ removePathsCrossing a b $ foldr insertWall (insertBlocks w) listWalls $ removePathsCrossing a b $ foldr insertWall (insertBlocks w) listWalls
where where
d = dist a b
rot = argV (b -.- a)
psOnLine = divideLineOddNumPoints blockWidth a b psOnLine = divideLineOddNumPoints blockWidth a b
halfBlockWidth = d / fromIntegral (length psOnLine - 1) halfBlockWidth = dist a b / fromIntegral (length psOnLine - 1)
blockCenPs = snd $ evenOddSplit psOnLine blockCenPs = snd $ evenOddSplit psOnLine
numBlocks = length blockCenPs numBlocks = length blockCenPs
is = [0.. numBlocks - 1] is = [0.. numBlocks - 1]
cornerPoints = reverse $ rectWH halfBlockWidth depth -- goes clockwise around the block 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 linesAt p = loopPairs $ cornersAt p
k = IM.newKey $ _walls w wlid = IM.newKey $ _walls w
blid = IM.newKey $ _blocks w blid = IM.newKey $ _blocks w
insertBlock i = over blocks $ IM.insert (i+blid) Block insertBlock i = over blocks $ IM.insert (i+blid) Block
{_blID = i + blid, _blWallIDs = IS.fromList $ ksAtI i, _blHPs = [5,5], _blShadows = shadowsAt i} {_blID = i + blid, _blWallIDs = IS.fromList $ ksAtI i, _blHPs = [5,5], _blShadows = shadowsAt i}
insertBlocks = flip (foldr insertBlock) is 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 visibilityAt i
| i == 0 = [ True,True,False,True] | i == 0 = [False,True,True ,True]
| i == numBlocks - 1 = [False,True, True,True] | i == numBlocks - 1 = [True ,True,False,True]
| otherwise = [False,True,False,True] | otherwise = [False,True,False,True]
shadowsAt i shadowsAt i
| i == 0 = ksAtI 1 | i == 0 = ksAtI 1
| i == numBlocks - 1 = ksAtI $ numBlocks - 2 | i == numBlocks - 1 = ksAtI $ numBlocks - 2
| otherwise = ksAtI (i-1) ++ ksAtI (i+1) | otherwise = ksAtI (i-1) ++ ksAtI (i+1)
makeWallAt p i = zipWith3 (makePane i) (visibilityAt i) (ksAtI i) (linesAt p) makeWallAt p i = zipWith3 (makePane i) (visibilityAt i) (ksAtI i) (linesAt p)
makePane i visStatus k' ps = basePane makePane i visStatus k ps = basePane
{_wlID = k' {_wlID = k
,_wlStructure = BlockPart $ i + blid ,_wlStructure = BlockPart $ i + blid
,_wlLine = ps ,_wlLine = ps
,_wlDraw = visStatus ,_wlDraw = visStatus
src/Dodge/LevelGen/Data.hs
+2
View File
@@ -18,6 +18,7 @@ data PSType = PutCrit {_unPutCrit :: Creature}
| PutFlIt Item | PutFlIt Item
| PutPressPlate PressPlate | PutPressPlate PressPlate
| PutBlock [Int] Color [Point2] | PutBlock [Int] Color [Point2]
| PutCoordinate Point2
| PutLineBlock Wall Float Float Point2 Point2 | PutLineBlock Wall Float Float Point2 Point2
| PutWall { _pwPoly :: [Point2] , _pwWall :: Wall } | PutWall { _pwPoly :: [Point2] , _pwWall :: Wall }
| PutSlideDoor Bool Color (World -> Bool) Point2 Point2 Float | PutSlideDoor Bool Color (World -> Bool) Point2 Point2 Float
@@ -36,6 +37,7 @@ data Placement = Placement
{ _placementSpot :: PlacementSpot { _placementSpot :: PlacementSpot
, _idPlacement :: Int -> Maybe Placement , _idPlacement :: Int -> Maybe Placement
} }
| PlacementPos Point3 (Point3 -> Placement)
sPS :: Point2 -> Float -> PSType -> 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)
src/Dodge/LevelGen/TriggerDoor.hs
+5 -3
View File
@@ -1,6 +1,6 @@
--{-# LANGUAGE BangPatterns #-} --{-# LANGUAGE BangPatterns #-}
module Dodge.LevelGen.TriggerDoor module Dodge.LevelGen.TriggerDoor
( putDoor ( placeDoor
, placeSlideDoor , placeSlideDoor
--, addButtonDoor --, addButtonDoor
) where ) where
@@ -24,14 +24,14 @@ import Data.List
import Control.Lens import Control.Lens
--import Data.Graph.Inductive hiding ((&)) --import Data.Graph.Inductive hiding ((&))
import qualified Data.IntSet as IS import qualified Data.IntSet as IS
putDoor placeDoor
:: Color :: Color
-> (World -> Bool) -- ^ Opening condition -> (World -> Bool) -- ^ Opening condition
-> [(Point2,Point2)] -- ^ Door positions, closed to open. -> [(Point2,Point2)] -- ^ Door positions, closed to open.
-- Bumped out up and down by 9, not widened -- Bumped out up and down by 9, not widened
-> World -> World
-> (Int,World) -> (Int,World)
putDoor col cond pss w = (drid, addWalls w & doors %~ addDoor) placeDoor col cond pss w = (drid, addWalls w & doors %~ addDoor)
where where
drid = IM.newKey $ _doors w drid = IM.newKey $ _doors w
addDoor = IM.insert drid $ Door addDoor = IM.insert drid $ Door
@@ -40,6 +40,7 @@ putDoor col cond pss w = (drid, addWalls w & doors %~ addDoor)
, _drStatus = DoorInt 0 , _drStatus = DoorInt 0
, _drTrigger = cond , _drTrigger = cond
, _drMech = doorMechanismStepwise nsteps drid wlids pss , _drMech = doorMechanismStepwise nsteps drid wlids pss
, _drCoord = 0
} }
nsteps = length pss - 1 nsteps = length pss - 1
wlids = take 4 [IM.newKey $ _walls w ..] 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 , _drStatus = DoorClosed
, _drTrigger = cond , _drTrigger = cond
, _drMech = doorMechanism drid speed (zip3 wlids shiftedPairs pairs) , _drMech = doorMechanism drid speed (zip3 wlids shiftedPairs pairs)
, _drCoord = 0
} }
addWalls w' = foldl' addWall w' $ zip wlids pairs addWalls w' = foldl' addWall w' $ zip wlids pairs
addWall w' (wlid, wlps) = w' & walls %~ IM.insert wlid defaultWall 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 module Dodge.Placements
( putDoubleDoor ( module Dodge.Placements.Door
, putDoubleDoorThen , module Dodge.Placements.LightSource
, putAutoDoor , module Dodge.Placements.Wall
, module Dodge.Placements.Button
) )
where where
import Dodge.Data import Dodge.Placements.Door
import Dodge.Base import Dodge.Placements.LightSource
import Color import Dodge.Placements.Wall
import Geometry import Dodge.Placements.Button
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
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
+18 -52
View File
@@ -1,25 +1,14 @@
-- | Module defining helper placements for rooms. module Dodge.Placements.Wall
module Dodge.Room.Placement
where where
import Dodge.Data import Dodge.Data
import Dodge.Default.Wall import Color
import Dodge.LevelGen.Data
import Dodge.LevelGen.Switch
import Dodge.Room.Data
import Dodge.Creature.Inanimate
import Picture
import Geometry import Geometry
import Dodge.LevelGen.Data
import Dodge.Default.Wall
import Dodge.Room.Data
import Data.List import Data.List
import Control.Lens 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 :: Point2 -> [Placement]
singleBlock a = singleBlock a =
[sPS a 0 [sPS a 0
@@ -110,6 +99,7 @@ baseWindowPane = defaultWall
, _wlDraw = True , _wlDraw = True
, _wlFireThrough = True , _wlFireThrough = True
} }
-- TODO find home for this
{- Replaces instances of a given 'PutID' with 'PSType's drawn from a list. -} {- Replaces instances of a given 'PutID' with 'PSType's drawn from a list. -}
replacePutID replacePutID
:: Int -- ^ The id of 'PutID' to be replaced :: Int -- ^ The id of 'PutID' to be replaced
@@ -134,51 +124,27 @@ subZipWith f g xs ys =
isPutID :: Int -> Placement -> Bool isPutID :: Int -> Placement -> Bool
isPutID i ps = Just i == ps ^? placementSpot . psType . putID isPutID i ps = Just i == ps ^? placementSpot . psType . putID
putBlockRect putBlockRect :: Float -> Float -> Float -> Float -> [Placement]
:: Float putBlockRect a x b y =
-> Float [ blockLine (V2 a b) (V2 a y)
-> Float
-> Float
-> [Placement]
putBlockRect a x b y = [ blockLine (V2 a b) (V2 a y)
, blockLine (V2 a y) (V2 x y) , blockLine (V2 a y) (V2 x y)
, blockLine (V2 x y) (V2 x b) , blockLine (V2 x y) (V2 x b)
, blockLine (V2 x b) (V2 a b) , blockLine (V2 x b) (V2 a b)
] ]
putBlockV putBlockV :: Float -> Float -> Float -> Float -> [Placement]
:: Float putBlockV a x b y =
-> Float [ blockLine (V2 a b) (V2 a y)
-> Float
-> Float
-> [Placement]
putBlockV a x b y = [ blockLine (V2 a b) (V2 a y)
, blockLine (V2 x b) (V2 a b) , blockLine (V2 x b) (V2 a b)
] ]
putBlockC putBlockC :: Float -> Float -> Float -> Float -> [Placement]
:: Float putBlockC a x b y =
-> Float [ blockLine (V2 a b) (V2 a y)
-> Float
-> Float
-> [Placement]
putBlockC a x b y = [ blockLine (V2 a b) (V2 a y)
, blockLine (V2 x b) (V2 a b) , blockLine (V2 x b) (V2 a b)
, blockLine (V2 a y) (V2 x y) , blockLine (V2 a y) (V2 x y)
] ]
putBlockN putBlockN :: Float -> Float -> Float -> Float -> [Placement]
:: Float putBlockN a x b y =
-> Float [ blockLine (V2 a b) (V2 a y)
-> 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 b) (V2 a b)
, blockLine (V2 x y) (V2 x 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
src/Dodge/Room.hs
+5 -18
View File
@@ -10,31 +10,20 @@ import Dodge.Item.Weapon.BulletGuns
import Dodge.Item.Weapon.Launcher import Dodge.Item.Weapon.Launcher
import Dodge.Creature import Dodge.Creature
import Dodge.Room.Foreground import Dodge.Room.Foreground
--import Dodge.Creature.Inanimate
--import Dodge.LevelGen
import Dodge.LevelGen.Data import Dodge.LevelGen.Data
--import Dodge.Base
import Dodge.RandomHelp import Dodge.RandomHelp
import Dodge.LevelGen
import Dodge.Default.Wall import Dodge.Default.Wall
--import Dodge.Path
--import Dodge.Layout
import Dodge.Layout.Tree.Polymorphic import Dodge.Layout.Tree.Polymorphic
import Dodge.Layout.Tree.Either import Dodge.Layout.Tree.Either
import Dodge.LightSources.Fitting import Dodge.Placements
--import Dodge.LightSources
--import Dodge.SoundLogic
import Dodge.Room.Data import Dodge.Room.Data
import Dodge.Room.Placement
import Dodge.Room.Procedural import Dodge.Room.Procedural
import Dodge.Room.Corridor import Dodge.Room.Corridor
import Dodge.Room.Link import Dodge.Room.Link
--import Dodge.Room.Branch
import Dodge.Room.Door import Dodge.Room.Door
import Dodge.Room.Airlock import Dodge.Room.Airlock
import Dodge.Room.LongDoor import Dodge.Room.LongDoor
import Geometry import Geometry
--import Geometry.Data
import Picture import Picture
import Tile import Tile
@@ -44,8 +33,6 @@ import Control.Monad.Loops
import System.Random import System.Random
import Data.Tree import Data.Tree
import Data.Bifunctor import Data.Bifunctor
--import qualified Data.Map as M
--import qualified Data.IntMap.Strict as IM
roomC :: Float -> Float -> Room roomC :: Float -> Float -> Room
roomC x y = defaultRoom roomC x y = defaultRoom
@@ -66,7 +53,7 @@ roomC x y = defaultRoom
yn = 4 yn = 4
yd = (y - 40) / fromIntegral yn yd = (y - 40) / fromIntegral yn
xd = (x - 40) / fromIntegral xn 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 :: [Point2] -> Point2 -> Room
roomPadCut ps p = defaultRoom roomPadCut ps p = defaultRoom
@@ -79,9 +66,9 @@ roomPadCut ps p = defaultRoom
roomPillars :: Room roomPillars :: Room
roomPillars = over rmLinks init $ set rmPS plmnts $ roomRect 240 240 2 2 roomPillars = over rmLinks init $ set rmPS plmnts $ roomRect 240 240 2 2
where where
plmnts = mountedLightI 70 (V2 120 24) (V2 120 216) plmnts = mountLightI 70 (V2 120 24) (V2 120 216)
: mountedLightV (V2 12 12) (V3 25 25 70) : mountLightV (V2 12 12) (V3 25 25 70)
: mountedLightV (V2 228 228) (V3 215 215 70) : mountLightV (V2 228 228) (V3 215 215 70)
: sps0 (PutForeground $ thinHighBar 75 (V2 26 25) (V2 120 25)) : sps0 (PutForeground $ thinHighBar 75 (V2 26 25) (V2 120 25))
: sps0 (PutForeground $ thinHighBar 75 (V2 214 215) (V2 120 215)) : sps0 (PutForeground $ thinHighBar 75 (V2 214 215) (V2 120 215))
: g 180 150 90 60 : 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. -} {- Rooms that contain two doors and a switch alternating both. -}
module Dodge.Room.Airlock where module Dodge.Room.Airlock where
import Dodge.Room.Data import Dodge.Room.Data
import Dodge.LightSources.Fitting import Dodge.Placements
import Dodge.Room.Placement
import Dodge.Room.Foreground import Dodge.Room.Foreground
import Dodge.Default.Room import Dodge.Default.Room
import Dodge.Data import Dodge.Data
import Dodge.Placements
import Dodge.LevelGen.Data import Dodge.LevelGen.Data
import Dodge.LevelGen.Switch import Dodge.LevelGen.Switch
import Dodge.RandomHelp import Dodge.RandomHelp
@@ -30,7 +28,7 @@ airlock0 = defaultRoom
[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 $ \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 $ 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) ,sps0 $ PutForeground $ thinHighBar 75 (V2 40 50) (V2 (-1) 50)
] ]
, _rmBound = [rectNSWE 75 15 0 40] , _rmBound = [rectNSWE 75 15 0 40]
@@ -65,7 +63,7 @@ airlock90 = defaultRoom
, _rmPS = , _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 $ \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 = , _rmBound =
[map toV2 [ (10,10) [map toV2 [ (10,10)
@@ -94,7 +92,7 @@ airlockCrystal = defaultRoom
[ 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 $ \btid -> jsps0 $ PutDoor col (cond btid) pss
, crystalLine (V2 0 70) (V2 40 70) , crystalLine (V2 0 70) (V2 40 70)
, mountedLightV (V2 150 70) (V3 110 70 70) , mountLightV (V2 150 70) (V3 110 70 70)
] ]
, _rmBound = , _rmBound =
[ ] [ ]
src/Dodge/Room/Boss.hs
+5 -6
View File
@@ -5,10 +5,9 @@ module Dodge.Room.Boss
where where
import Dodge.Data import Dodge.Data
import Dodge.Default.Room import Dodge.Default.Room
import Dodge.LightSources.Fitting import Dodge.Placements
import Dodge.Room.Data import Dodge.Room.Data
import Dodge.Room.Procedural import Dodge.Room.Procedural
import Dodge.Room.Placement
import Dodge.Room.Link import Dodge.Room.Link
import Dodge.Room.Corridor import Dodge.Room.Corridor
import Dodge.Room.Path import Dodge.Room.Path
@@ -98,8 +97,8 @@ roomCross x y = defaultRoom
] ]
, _rmPath = [] , _rmPath = []
, _rmPS = , _rmPS =
[ mountedLightI 70 (V2 (x+5) x) (V2 (x+5) (-x)) [ mountLightI 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))
] ]
, _rmBound = , _rmBound =
[rectNSWE y (-y) (-x) x [rectNSWE y (-y) (-x) x
@@ -122,7 +121,7 @@ roomShuriken x y =
{ _rmPolys = ps { _rmPolys = ps
, _rmLinks = [(V2 (x-1) (y-20),negate $ pi/2)] , _rmLinks = [(V2 (x-1) (y-20),negate $ pi/2)]
, _rmPath = [] , _rmPath = []
, _rmPS = [mountedLight (V2 x x) (V3 (x-20) x 70)] , _rmPS = [mountLight (V2 x x) (V3 (x-20) x 70)]
, _rmBound = ps , _rmBound = ps
} }
in foldr1 combineRooms $ map (\r -> shiftRoomBy (V2 0 0, r) corner) [0,pi/2,pi,3*pi/2] 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 { _rmPolys = ps
, _rmLinks = [(V2 z (y-20), pi/2)] , _rmLinks = [(V2 z (y-20), pi/2)]
, _rmPath = [] , _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 , _rmBound = ps
} }
in foldr1 combineRooms $ map (\r -> shiftRoomBy (V2 0 0, r) corner) [0,pi/2,pi,3*pi/2] 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.Default.Room
--import Dodge.LevelGen.Data --import Dodge.LevelGen.Data
--import Dodge.LightSources.Lamp --import Dodge.LightSources.Lamp
import Dodge.LightSources.Fitting import Dodge.Placements
import Geometry import Geometry
import Tile import Tile
@@ -17,7 +17,7 @@ corridor = defaultRoom
{ _rmPolys = [poly] { _rmPolys = [poly]
, _rmLinks = lnks , _rmLinks = lnks
, _rmPath = concatMap (doublePair . (,) (V2 20 60) . fst) 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 ] , _rmBound = [ rectNSWE 50 30 0 40 ]
, _rmFloor = [makeTileFromPoly poly 2] , _rmFloor = [makeTileFromPoly poly 2]
} }
src/Dodge/Room/LongDoor.hs
+46 -35
View File
@@ -6,24 +6,23 @@ module Dodge.Room.LongDoor
import Dodge.Data import Dodge.Data
import Dodge.Default.Room import Dodge.Default.Room
import Dodge.Room.Data import Dodge.Room.Data
import Dodge.Room.Placement import Dodge.Placements
import Dodge.Room.Link import Dodge.Room.Link
import Dodge.Room.Procedural import Dodge.Room.Procedural
import Dodge.Layout.Tree.Either --import Dodge.Layout.Tree.Either
import Dodge.LevelGen.Data import Dodge.LevelGen.Data
import Dodge.LevelGen.Switch import Dodge.LevelGen.Switch
import Dodge.RandomHelp import Dodge.RandomHelp
import Dodge.Creature.Inanimate import Dodge.Creature.Inanimate
import Dodge.Creature import Dodge.Creature
import Dodge.LightSources.Lamp import Dodge.LightSources.Lamp
import Dodge.Placements
import Picture import Picture
import Geometry import Geometry
import System.Random import System.Random
import Control.Lens import Control.Lens
import Control.Monad.State import Control.Monad.State
import Data.Tree --import Data.Tree
import qualified Data.IntMap as IM import qualified Data.IntMap as IM
twinSlowDoorRoom twinSlowDoorRoom
@@ -76,15 +75,51 @@ twinSlowDoorChasers = do
let plmnts = map (\p -> sPS p 0 $ PutCrit chaseCrit) ps let plmnts = map (\p -> sPS p 0 $ PutCrit chaseCrit) ps
return $ twinSlowDoorRoom 80 200 40 & rmPS %~ (plmnts ++) return $ twinSlowDoorRoom 80 200 40 & rmPS %~ (plmnts ++)
slowDoorRoom :: RandomGen g => State g (Tree (Either Room Room)) southPillarsRoom :: RandomGen g => Float -> Float -> Float -> State g Room
slowDoorRoom = do southPillarsRoom x y h = do
x <- state $ randomR (400,800) let pillarsa = []
y <- state $ randomR (400,800) pillarsb = putBlockRect (x/5-20) (x/5+20) (h/2-20) (h/2+20)
h <- state $ randomR (200,min (y-100) 500) ++ 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 (butPos,butRot) <- takeOne
[( V2 (x/2-50) 5,0) [( V2 (x/2-50) 5,0)
,( 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
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
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 let n = 25
xs <- replicateM n $ state $ randomR (10,x-10) xs <- replicateM n $ state $ randomR (10,x-10)
ys <- replicateM n $ state $ randomR (h+20,y) ys <- replicateM n $ state $ randomR (h+20,y)
@@ -95,32 +130,8 @@ slowDoorRoom = do
let crits = zipWith (\p r -> sPS p r randC1) ps rs 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] 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' barrels = zipWith (\x' y' -> sPS (V2 x' y') 0 $ PutCrit explosiveBarrel) xs' ys'
pillarsa = [] proom <- southPillarsRoom x y h
pillarsb = putBlockRect (x/5-20) (x/5+20) (h/2-20) (h/2+20) addButtonSlowDoor x h (proom & rmPS %~ (++ (crits ++ barrels ++ lsources)))
++ 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
)
)
where
butDoor x h bpos brot
= ps0 (PutButton $ (makeButton col id) {_btPos = bpos, _btRot = 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
randC1 :: PSType randC1 :: PSType
randC1 = RandPS $ takeOne $ map PutCrit $ armourChaseCrit : replicate 50 chaseCrit 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.Data
import Dodge.Default.Wall import Dodge.Default.Wall
import Dodge.Room.Data import Dodge.Room.Data
import Dodge.Room.Placement import Dodge.Placements
import Dodge.Room.Link import Dodge.Room.Link
import Dodge.Room.Path import Dodge.Room.Path
import Dodge.Default.Room import Dodge.Default.Room
@@ -24,7 +24,7 @@ import Dodge.Item.Weapon.Launcher
import Dodge.RandomHelp import Dodge.RandomHelp
import Dodge.LevelGen import Dodge.LevelGen
import Dodge.LevelGen.Data import Dodge.LevelGen.Data
import Dodge.LightSources.Fitting import Dodge.LevelGen.Switch
import Dodge.Creature import Dodge.Creature
import Geometry import Geometry
import Geometry.Vector3D import Geometry.Vector3D
@@ -60,12 +60,12 @@ roomRect x y xn yn = defaultRoom
where where
yd = (y - 40) / fromIntegral yn yd = (y - 40) / fromIntegral yn
xd = (x - 40) / fromIntegral xn xd = (x - 40) / fromIntegral xn
elnks = zip (translateS (V2 0 20) $ gridPoints 0 1 yd (yn+1)) (repeat ( pi/2)) elnks = zip (map (+.+ 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)) wlnks = zip (map (+.+ 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 ) nlnks = zip (map (+.+ 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 ) slnks = zip (map (+.+ V2 20 0) $ gridPoints xd (xn+1) 0 1 ) (repeat pi )
lnks = nlnks ++ elnks ++ wlnks ++ slnks 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. -} {- Creates a rectangular room, automatically creates links and pathfinding graph at a sensible size. -}
roomRectAutoLinks :: Float -> Float -> Room roomRectAutoLinks :: Float -> Float -> Room
roomRectAutoLinks x y = roomRect x y ((ceiling x - 40) `div` 60) ((ceiling y - 40) `div` 60) 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 :: RandomGen g => Float -> State g Room
quarterRoomFlat w = do quarterRoomFlat w = do
b <- takeOne b <- takeOne
[ [ mountedLightV (V2 0 w) (V3 0 (w-20) 70) [ [ mountLightV (V2 0 w) (V3 0 (w-20) 70)
, 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 , sPS (V2 (w-20) (w-20)) pi PutNothing
, blockLine (V2 (w/2) (w/2)) (V2 (w/2) w) , 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 , sPS (V2 (w-20) (w-20)) pi PutNothing
, blockLine (V2 (w/2) (w/2)) (V2 (negate $ w/2) (w/2)) , 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 , sPS (V2 (w-20) (w-20)) pi PutNothing
, blockLine (V2 (w/2) (w/2)) (V2 0 (w/2)) , blockLine (V2 (w/2) (w/2)) (V2 0 (w/2))
, blockLine (V2 (-29) w) (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 :: RandomGen g => Float -> State g Room
fourthCornerWall w = do fourthCornerWall w = do
b <- takeOne 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 (w/2) (w/2)) (V2 0 w)
, blockLine (V2 (negate $ 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 , 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 (w/2) (w/2)) (V2 0 w)
, blockLine (V2 (negate w) w ) (V2 0 w) , blockLine (V2 (negate w) w ) (V2 0 w)
, sPS (V2 20 (2*w-40)) pi PutNothing , 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 (w/2) (w/2)) (V2 0 w)
, blockLine (V2 0 w) (V2 0 (w*2)) , blockLine (V2 0 w) (V2 0 (w*2))
, sPS (V2 20 (2*w-40)) pi PutNothing , 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 $ PutWall (rectNSEW (-d) (30 - d) (-d) (30 - d)) defaultWall
,sps0 $ PutForeground $ girder 70 10 10 (V2 (d-11) (-d)) (V2 (d-11) (-h)) ,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] [0,0.5*pi,pi,1.5*pi]
++ concatMap (\r -> map (shiftPlacement (V2 0 0,r)) theDoor) ++ concatMap (\r -> map (shiftPlacement (V2 0 0,r)) theDoor)
[0,pi/2,pi,3*pi/2] [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.Default.Room
import Dodge.Room.Data import Dodge.Room.Data
import Dodge.Room.Link import Dodge.Room.Link
import Dodge.Room.Placement import Dodge.Placements
import Dodge.Room.Corridor import Dodge.Room.Corridor
import Dodge.LevelGen.Data import Dodge.LevelGen.Data
--import Dodge.RandomHelp --import Dodge.RandomHelp
import Dodge.Creature import Dodge.Creature
import Dodge.Layout.Tree.Polymorphic import Dodge.Layout.Tree.Polymorphic
import Dodge.LightSources.Fitting
import Data.Tree import Data.Tree
import Control.Monad.State import Control.Monad.State
@@ -43,7 +42,7 @@ litCorridor90 = do
] ]
, _rmPS = , _rmPS =
[ sPS (V2 20 (h-5)) 0 putLamp [ 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)) , windowLine (V2 0 (h-20)) (V2 40 (h-20))
, sPS (V2 (-50) (h-85)) 0 putLamp , sPS (V2 (-50) (h-85)) 0 putLamp
, windowLine (V2 (-40) (h-60)) (V2 (-40) (h-100)) , windowLine (V2 (-40) (h-60)) (V2 (-40) (h-100))
@@ -76,6 +75,6 @@ blockedCorridor = do
let plmnts = let plmnts =
[sPS (V2 20 40) r $ PutBlock [5,5,5] (V4 (150/256) ( 75/256) 0 ( 250/256)) [sPS (V2 20 40) r $ PutBlock [5,5,5] (V4 (150/256) ( 75/256) 0 ( 250/256))
$ reverse $ rectNSWE 10 (-10) (-10) 10 $ 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 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.Procedural
import Dodge.Room.Foreground import Dodge.Room.Foreground
import Dodge.Room.Furniture import Dodge.Room.Furniture
import Dodge.Placements
import Dodge.Layout.Tree.Polymorphic import Dodge.Layout.Tree.Polymorphic
import Dodge.LevelGen.Data import Dodge.LevelGen.Data
import Dodge.LightSources.Fitting
import Dodge.Machine.Sensor import Dodge.Machine.Sensor
import Geometry.Data import Geometry.Data
import Color import Color
@@ -33,7 +33,7 @@ startRoom = do
<$> randomiseOutLinks (shiftRoomBy (V2 (-20) (-20),0) <$> randomiseOutLinks (shiftRoomBy (V2 (-20) (-20),0)
$ roomRectAutoLinks w h & rmPS .~ $ roomRectAutoLinks w h & rmPS .~
[ fground [ 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) , tankSquareEmboss4 (dim orange) 50 (h-60)
, tankSquare (dim orange) 50 50 , tankSquare (dim orange) 50 50
, tankSquare (dim orange) 50 120 , 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.Base
import Dodge.Room.Data import Dodge.Room.Data
import Dodge.Room.Procedural import Dodge.Room.Procedural
import Dodge.Room.Placement import Dodge.Placements
import Dodge.LevelGen.Data import Dodge.LevelGen.Data
import Geometry import Geometry
import Picture import Picture
src/Dodge/Room/Treasure.hs
+2 -3
View File
@@ -6,10 +6,9 @@ module Dodge.Room.Treasure
where where
import Dodge.Data import Dodge.Data
import Dodge.Room.Data import Dodge.Room.Data
import Dodge.Room.Placement import Dodge.Placements
import Dodge.Default.Room import Dodge.Default.Room
import Dodge.LevelGen.Data import Dodge.LevelGen.Data
import Dodge.LightSources.Fitting
import Geometry import Geometry
--import Data.List --import Data.List
@@ -33,7 +32,7 @@ triLootRoom w h = pure $ defaultRoom
[sPS (V2 (15-w) 15 ) 0 $ PutID 0 [sPS (V2 (15-w) 15 ) 0 $ PutID 0
,sPS (V2 (w-15) 15 ) pi $ PutID 0 ,sPS (V2 (w-15) 15 ) pi $ PutID 0
,sPS (V2 0 (h-35)) 0 $ PutID 2 ,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 ,sPS (V2 0 ( -60)) 0 putLamp
] ]
, _rmBound = [tri , base] , _rmBound = [tri , base]