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

Remove separate wall color, should be handled by material type

Browse Source
This commit is contained in:
justin
2025-10-23 21:27:14 +01:00
parent 819f0d37ea
commit 3c6d269d00
24 changed files with 136 additions and 123 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Block/Debris.hs
+22 -11
View File
@@ -7,9 +7,9 @@ module Dodge.Block.Debris (
makeDebrisDirected, makeDebrisDirected,
) where ) where
import Dodge.Material.Color
import qualified Data.IntMap.Strict as IM import qualified Data.IntMap.Strict as IM
import Dodge.ShiftPoint import Dodge.ShiftPoint
import Color
import Data.Foldable import Data.Foldable
import qualified Data.IntSet as IS import qualified Data.IntSet as IS
import Data.Maybe import Data.Maybe
@@ -24,32 +24,41 @@ import RandomHelp
import Shape import Shape
makeDoorDebris :: Door -> World -> World makeDoorDebris :: Door -> World -> World
makeDoorDebris dr w = w & makeDebris mt col p --makeDoorDebris dr w = w & makeDebris mt col p
makeDoorDebris dr w = w & makeDebris mt p
where where
p2a = lerpP2A (dr ^. drZeroPos) (dr ^. drOnePos) (dr ^. drLerp) p2a = lerpP2A (dr ^. drZeroPos) (dr ^. drOnePos) (dr ^. drLerp)
p = centroid . fmap fst $ (dr ^. drFootPrint) & each . each %~ shiftPointBy p2a p = centroid . fmap fst $ (dr ^. drFootPrint) & each . each %~ shiftPointBy p2a
(mt, col) = fromMaybe (Stone, greyN 0.5) $ do --(mt, col) = fromMaybe (Stone, greyN 0.5) $ do
mt = fromMaybe Stone $ do
wlids <- w ^? cWorld . lWorld . doors . ix (_drID dr) . drFootPrint wlids <- w ^? cWorld . lWorld . doors . ix (_drID dr) . drFootPrint
((wlid,_),_) <- IM.minViewWithKey wlids ((wlid,_),_) <- IM.minViewWithKey wlids
wl <- w ^? cWorld . lWorld . walls . ix wlid wl <- w ^? cWorld . lWorld . walls . ix wlid
return (_wlMaterial wl, _wlColor wl) --return (_wlMaterial wl, _wlColor wl)
return $ wl ^. wlMaterial
makeBlockDebris :: Block -> World -> World makeBlockDebris :: Block -> World -> World
makeBlockDebris bl w = foldl' (flip $ makeDebris mt col) w ps --makeBlockDebris bl w = foldl' (flip $ makeDebris mt col) w ps
makeBlockDebris bl w = foldl' (flip $ makeDebris mt) w ps
where where
dsize = debrisSize mt dsize = debrisSize mt
ps = gridInPolygon dsize $ shrinkPolyOnEdges dsize $ reverse (_blFootprint bl) ps = gridInPolygon dsize $ shrinkPolyOnEdges dsize $ reverse (_blFootprint bl)
(mt, col) = fromMaybe (Stone, greyN 0.5) $ do --(mt, col) = fromMaybe (Stone, greyN 0.5) $ do
mt = fromMaybe Stone $ do
wlids <- w ^? cWorld . lWorld . blocks . ix (_blID bl) . blWallIDs wlids <- w ^? cWorld . lWorld . blocks . ix (_blID bl) . blWallIDs
(wlid, _) <- IS.minView wlids (wlid, _) <- IS.minView wlids
wl <- w ^? cWorld . lWorld . walls . ix wlid wl <- w ^? cWorld . lWorld . walls . ix wlid
return (_wlMaterial wl, _wlColor wl) --return (_wlMaterial wl, _wlColor wl)
return $ _wlMaterial wl
makeDebris :: Material -> Color -> Point2 -> World -> World --makeDebris :: Material -> Color -> Point2 -> World -> World
makeDebris :: Material -> Point2 -> World -> World
makeDebris = makeDebrisDirected (2 * pi) 0 makeDebris = makeDebrisDirected (2 * pi) 0
makeDebrisDirected :: Float -> Float -> Material -> Color -> Point2 -> World -> World makeDebrisDirected :: Float -> Float -> Material -> Point2 -> World -> World
makeDebrisDirected arcrad dir bm col p w = --makeDebrisDirected :: Float -> Float -> Material -> Color -> Point2 -> World -> World
--makeDebrisDirected arcrad dir bm col p w =
makeDebrisDirected arcrad dir bm p w =
w w
-- & flip (foldl' (flip $ plNew (cWorld . lWorld . props) prID)) thedebris -- & flip (foldl' (flip $ plNew (cWorld . lWorld . props) prID)) thedebris
& cWorld . lWorld . debris <>~ thedebris & cWorld . lWorld . debris <>~ thedebris
@@ -63,7 +72,8 @@ makeDebrisDirected arcrad dir bm col p w =
-- basedebris <- baseDebris bm -- basedebris <- baseDebris bm
return $ DebrisChunk return $ DebrisChunk
{ _dbPos = p `v2z` h { _dbPos = p `v2z` h
, _dbType = BlockDebris col -- , _dbType = BlockDebris col
, _dbType = BlockDebris (materialColor bm)
, _dbVel = v `v2z` 0 , _dbVel = v `v2z` 0
, _dbRot = Q.qID , _dbRot = Q.qID
, _dbSpin = Q.axisAngle (vNormal v `v2z` 0) spinspeed , _dbSpin = Q.axisAngle (vNormal v `v2z` 0) spinspeed
@@ -87,6 +97,7 @@ debrisSize mt = case mt of
Metal -> 10 Metal -> 10
Electronics -> 10 Electronics -> 10
Flesh -> 10 Flesh -> 10
ForceField -> 10
--shardShape :: Float -> Shape --shardShape :: Float -> Shape
--shardShape size = --shardShape size =
src/Dodge/Bullet.hs
+7 -2
View File
@@ -107,8 +107,9 @@ updateBulVel bt = bt & buVel .*.*~ _buDrag bt
-- tpos <- cr ^? crTargeting . ctPos . _Just -- tpos <- cr ^? crTargeting . ctPos . _Just
-- return $ BezierTrajectory sp tpos (mouseWorldPos (w ^. input) (w ^. wCam)) -- return $ BezierTrajectory sp tpos (mouseWorldPos (w ^. input) (w ^. wCam))
-- might want to restrict what/how bounces by material type
bounceDir :: IM.IntMap Item -> (Point2, Either Creature Wall) -> Maybe Point2 bounceDir :: IM.IntMap Item -> (Point2, Either Creature Wall) -> Maybe Point2
bounceDir _ (_, Right wl) | _wlBouncy wl = Just $ uncurry (-) (_wlLine wl) bounceDir _ (_, Right wl) = Just $ uncurry (-) (_wlLine wl)
bounceDir m (p, Left cr) | crIsArmouredFrom m p cr bounceDir m (p, Left cr) | crIsArmouredFrom m p cr
= Just $ vNormal $ p - (cr ^. crPos . _xy) = Just $ vNormal $ p - (cr ^. crPos . _xy)
bounceDir _ _ = Nothing bounceDir _ _ = Nothing
@@ -207,6 +208,10 @@ movePenBullet bu hitstream w = case hitstream of
first (damageThingHit bu (p, crwl)) $ movePenBullet bu strm w first (damageThingHit bu (p, crwl)) $ movePenBullet bu strm w
_ -> expireAndDamage bu hitstream w _ -> expireAndDamage bu hitstream w
materialPenetrable :: Material -> Bool
materialPenetrable _ = error "Haven't decided which materials are peneterable"
penThing :: Either Creature Wall -> Bool penThing :: Either Creature Wall -> Bool
penThing (Left _) = True penThing (Left _) = True
penThing (Right wl) = _wlPenetrable wl penThing (Right wl) = _wlStructure wl /= StandaloneWall
&& materialPenetrable (wl ^. wlMaterial)
src/Dodge/Data/GenWorld.hs
+1 -2
View File
@@ -9,7 +9,6 @@ module Dodge.Data.GenWorld (
) where ) where
import ShortShow import ShortShow
import Color
import Control.Lens import Control.Lens
import Control.Monad.State import Control.Monad.State
import qualified Data.Set as S import qualified Data.Set as S
@@ -55,7 +54,7 @@ data PSType
| PutWall {_pwPoly :: [Point2], _pwWall :: Wall} | PutWall {_pwPoly :: [Point2], _pwWall :: Wall}
| PutSlideDr Door Wall (S.Set EdgeObstacle) Float Point2 Point2 | PutSlideDr Door Wall (S.Set EdgeObstacle) Float Point2 Point2
-- | PutDoor Color EdgeObstacle WdBl [(Point2, Point2)] -- | PutDoor Color EdgeObstacle WdBl [(Point2, Point2)]
| PutDoor Color (S.Set EdgeObstacle) WdBl Float Point2A Point2A -- [(Point2, Point2)] | PutDoor (S.Set EdgeObstacle) WdBl Float Point2A Point2A -- [(Point2, Point2)]
| RandPS (State StdGen PSType) | RandPS (State StdGen PSType)
| PutForeground ForegroundShape | PutForeground ForegroundShape
| PutWorldUpdate (Int -> PlacementSpot -> GenWorld -> GenWorld) | PutWorldUpdate (Int -> PlacementSpot -> GenWorld -> GenWorld)
src/Dodge/Data/Material.hs
+10 -1
View File
@@ -6,7 +6,16 @@ module Dodge.Data.Material where
import Data.Aeson import Data.Aeson
import Data.Aeson.TH import Data.Aeson.TH
data Material = Wood | Dirt | Stone | Glass | Metal | Crystal | Flesh | Electronics data Material
= Wood
| Dirt
| Stone
| Glass
| Metal
| Crystal
| Flesh
| Electronics
| ForceField
deriving (Eq, Ord, Show, Bounded, Enum, Read) --Generic, Flat) deriving (Eq, Ord, Show, Bounded, Enum, Read) --Generic, Flat)
deriveJSON defaultOptions ''Material deriveJSON defaultOptions ''Material
src/Dodge/Data/Wall.hs
+1 -6
View File
@@ -7,7 +7,6 @@ module Dodge.Data.Wall (
module Dodge.Data.Material, module Dodge.Data.Material,
) where ) where
import Color
import Control.Lens import Control.Lens
import Data.Aeson import Data.Aeson
import Data.Aeson.TH import Data.Aeson.TH
@@ -19,14 +18,10 @@ import qualified Data.Set as S
data Wall = Wall data Wall = Wall
{ _wlLine :: (Point2, Point2) { _wlLine :: (Point2, Point2)
, _wlID :: Int , _wlID :: Int
, _wlColor :: Color -- , _wlColor :: Color
, _wlOpacity :: Opacity , _wlOpacity :: Opacity
, _wlPathFlag :: S.Set WallFlag , _wlPathFlag :: S.Set WallFlag
, _wlPenetrable :: Bool
, _wlBouncy :: Bool
, _wlWalkable :: Bool
, _wlTouchThrough :: Bool , _wlTouchThrough :: Bool
, _wlFireThrough :: Bool
, _wlUnshadowed :: Bool , _wlUnshadowed :: Bool
, _wlRotateTo :: Bool , _wlRotateTo :: Bool
, _wlStructure :: WallStructure , _wlStructure :: WallStructure
src/Dodge/Default/Door.hs
+4 -5
View File
@@ -3,25 +3,24 @@ module Dodge.Default.Door (
module Dodge.Default.Wall, module Dodge.Default.Wall,
) where ) where
import Color
import Control.Lens import Control.Lens
import Dodge.Data.Door import Dodge.Data.Door
import Dodge.Data.Wall import Dodge.Data.Wall
import Dodge.Default.Wall import Dodge.Default.Wall
switchWallCol :: Color -> Wall --switchWallCol :: Color -> Wall
switchWallCol col = defaultSwitchWall & wlColor .~ col --switchWallCol col = defaultSwitchWall
defaultAutoWall :: Wall defaultAutoWall :: Wall
defaultAutoWall = defaultAutoWall =
defaultDoorWall defaultDoorWall
& wlColor .~ dim yellow -- & wlColor .~ dim yellow
& wlOpacity .~ Opaque 9 & wlOpacity .~ Opaque 9
defaultSwitchWall :: Wall defaultSwitchWall :: Wall
defaultSwitchWall = defaultSwitchWall =
defaultDoorWall defaultDoorWall
& wlColor .~ red -- & wlColor .~ red
& wlOpacity .~ Opaque 0 & wlOpacity .~ Opaque 0
defaultDoor :: Door defaultDoor :: Door
src/Dodge/Default/Wall.hs
+19 -29
View File
@@ -8,11 +8,10 @@ module Dodge.Default.Wall (
defaultDirtWall, defaultDirtWall,
) where ) where
import qualified Data.Set as S
import Control.Lens import Control.Lens
import qualified Data.Set as S
import Dodge.Data.Wall import Dodge.Data.Wall
import Geometry.Data import Geometry.Data
import Picture
{- Indestructible wall. -} {- Indestructible wall. -}
defaultWall :: Wall defaultWall :: Wall
@@ -20,34 +19,34 @@ defaultWall =
Wall Wall
{ _wlLine = (V2 0 0, V2 50 0) { _wlLine = (V2 0 0, V2 50 0)
, _wlID = 0 , _wlID = 0
, _wlColor = greyN 0.6 -- , _wlColor = greyN 0.6
, _wlPathFlag = S.fromList [WallBlockVisibility , _wlPathFlag =
, WallNotAutoOpen, WallNotDestrucable] S.fromList
[ WallBlockVisibility
, WallNotAutoOpen
, WallNotDestrucable
]
, _wlOpacity = Opaque 11 , _wlOpacity = Opaque 11
, _wlPenetrable = False
, _wlFireThrough = False
, _wlTouchThrough = False
, _wlUnshadowed = True , _wlUnshadowed = True
, _wlRotateTo = True , _wlRotateTo = True
, _wlStructure = StandaloneWall , _wlStructure = StandaloneWall
, _wlWalkable = False
, _wlHeight = 100 , _wlHeight = 100
, _wlMaterial = Stone , _wlMaterial = Stone
, _wlBouncy = True , _wlTouchThrough = False
} }
defaultDoorWall :: Wall defaultDoorWall :: Wall
defaultDoorWall = defaultWall { _wlMaterial = Metal } defaultDoorWall =
defaultWall{_wlMaterial = Metal}
& wlPathFlag . at WallNotDestrucable .~ Nothing & wlPathFlag . at WallNotDestrucable .~ Nothing
{- Indestructible see-through wall. -} {- Indestructible see-through wall. -}
defaultCrystalWall :: Wall defaultCrystalWall :: Wall
defaultCrystalWall = defaultCrystalWall = defaultWall & wlOpacity .~ SeeThrough & wlMaterial .~ Crystal
defaultWall -- { _wlColor = withAlpha 0.5 aquamarine
{ _wlColor = withAlpha 0.5 aquamarine -- , _wlOpacity = SeeThrough
, _wlOpacity = SeeThrough -- , _wlMaterial = Crystal
, _wlMaterial = Crystal -- }
}
defaultMachineWall :: Wall defaultMachineWall :: Wall
defaultMachineWall = defaultMachineWall =
@@ -56,37 +55,28 @@ defaultMachineWall =
, _wlRotateTo = False , _wlRotateTo = False
, _wlStructure = MachinePart 0 , _wlStructure = MachinePart 0
, _wlMaterial = Metal , _wlMaterial = Metal
, _wlPenetrable = True
} }
defaultSensorWall :: Wall defaultSensorWall :: Wall
defaultSensorWall = defaultMachineWall & wlBouncy .~ False defaultSensorWall = defaultMachineWall
defaultDirtWall :: Wall defaultDirtWall :: Wall
defaultDirtWall = defaultDirtWall =
defaultWall defaultWall
{ _wlLine = (V2 0 0, V2 50 0) { _wlLine = (V2 0 0, V2 50 0)
, _wlID = 0 , _wlID = 0
, _wlColor = dirtColor -- , _wlColor = dirtColor
, _wlOpacity = Opaque 6 , _wlOpacity = Opaque 6
, _wlRotateTo = False , _wlRotateTo = False
, _wlFireThrough = False
, _wlPenetrable = True
, _wlMaterial = Dirt , _wlMaterial = Dirt
} }
dirtColor :: Color
dirtColor = dark $ dark orange
--dirtColor = V4 (150 / 256) (75 / 256) 0 (250 / 256)
defaultWindow :: Wall defaultWindow :: Wall
defaultWindow = defaultWindow =
defaultWall defaultWall
{ _wlLine = (V2 0 0, V2 50 0) { _wlLine = (V2 0 0, V2 50 0)
, _wlID = 0 , _wlID = 0
, _wlColor = withAlpha 0.5 cyan -- , _wlColor = withAlpha 0.5 cyan
, _wlOpacity = SeeThrough , _wlOpacity = SeeThrough
, _wlFireThrough = False
, _wlMaterial = Glass , _wlMaterial = Glass
, _wlPenetrable = True
} }
src/Dodge/Item/BackgroundEffect.hs
+4 -5
View File
@@ -7,7 +7,6 @@ module Dodge.Item.BackgroundEffect (
) where ) where
import Linear import Linear
import Color
import Control.Lens import Control.Lens
import Dodge.Creature.Radius import Dodge.Creature.Radius
import Dodge.Creature.Test import Dodge.Creature.Test
@@ -78,11 +77,11 @@ itEffectOnDrop itm cr w = case itm ^. itType of
shieldWall :: Int -> Wall shieldWall :: Int -> Wall
shieldWall crid = shieldWall crid =
defaultWall defaultWall
{ _wlColor = yellow { --_wlColor = yellow
, _wlOpacity = SeeAbove _wlOpacity = SeeAbove
, _wlWalkable = True
, _wlFireThrough = False
, _wlMaterial = Metal , _wlMaterial = Metal
, _wlRotateTo = False , _wlRotateTo = False
, _wlStructure = CreaturePart crid -- shieldWallDamage , _wlStructure = CreaturePart crid -- shieldWallDamage
, _wlPathFlag = mempty
} }
& wlPathFlag .~ mempty
src/Dodge/Item/Weapon/Shatter.hs
+3 -2
View File
@@ -27,11 +27,12 @@ shootShatter _ cr w =
shatterWall :: World -> Point2 -> Point2 -> Point2 -> Wall -> World shatterWall :: World -> Point2 -> Point2 -> Point2 -> Wall -> World
shatterWall w sp ep p wl = shatterWall w sp ep p wl =
w w
& makeDebris (_wlMaterial wl) (_wlColor wl) p -- & makeDebris (_wlMaterial wl) (_wlColor wl) p
& makeDebris (_wlMaterial wl) p
& makeDebrisDirected & makeDebrisDirected
(pi / 2) (pi / 2)
(argV $ vNormal $ uncurry (-) $ _wlLine wl) (argV $ vNormal $ uncurry (-) $ _wlLine wl)
(_wlMaterial wl) (_wlMaterial wl)
(_wlColor wl) -- (_wlColor wl)
p p
& damageWall (Shattering 1000 p (ep - sp)) wl & damageWall (Shattering 1000 p (ep - sp)) wl
src/Dodge/Material/Color.hs
+1
View File
@@ -16,3 +16,4 @@ materialColor =
Crystal -> green Crystal -> green
Flesh -> red Flesh -> red
Electronics -> greyN 0.2 Electronics -> greyN 0.2
ForceField -> magenta
src/Dodge/Material/Sound.hs
+2
View File
@@ -14,6 +14,7 @@ destroyMatS mat = case mat of
Metal -> [metal1S, metal2S, metal3S, metal4S, metal5S, metal6S,metal7S] Metal -> [metal1S, metal2S, metal3S, metal4S, metal5S, metal6S,metal7S]
Electronics -> [metal1S, metal2S, metal3S, metal4S, metal5S, metal6S,metal7S] Electronics -> [metal1S, metal2S, metal3S, metal4S, metal5S, metal6S,metal7S]
Flesh -> [gut1S, gut2S, gut3S, gut4S, gut5S, gut6S] Flesh -> [gut1S, gut2S, gut3S, gut4S, gut5S, gut6S]
ForceField -> []
weakenMatS :: Material -> [SoundID] weakenMatS :: Material -> [SoundID]
weakenMatS mat = case mat of weakenMatS mat = case mat of
@@ -25,3 +26,4 @@ weakenMatS mat = case mat of
Metal -> [metal1S, metal2S, metal3S, metal4S, metal5S, metal6S, metal7S] Metal -> [metal1S, metal2S, metal3S, metal4S, metal5S, metal6S, metal7S]
Electronics -> [metal1S, metal2S, metal3S, metal4S, metal5S, metal6S, metal7S] Electronics -> [metal1S, metal2S, metal3S, metal4S, metal5S, metal6S, metal7S]
Flesh -> [blood1S, blood2S, blood3S, blood4S, blood5S, blood6S, blood7S, blood8S] Flesh -> [blood1S, blood2S, blood3S, blood4S, blood5S, blood6S, blood7S, blood8S]
ForceField -> []
src/Dodge/Placement/Instance/Block.hs
+1 -1
View File
@@ -18,7 +18,7 @@ decoratedBlock decf mat col h ps = PutBlock bl wl $ reverse ps
& blMaterial .~ mat & blMaterial .~ mat
wl = wl =
defaultWall defaultWall
& wlColor .~ col -- & wlColor .~ col
& wlRotateTo .~ False & wlRotateTo .~ False
& wlOpacity .~ SeeAbove & wlOpacity .~ SeeAbove
& wlMaterial .~ mat & wlMaterial .~ mat
src/Dodge/Placement/Instance/Door.hs
+2 -1
View File
@@ -111,7 +111,8 @@ switchDoor btpos btrot dra drb col = pContID
jsps0J (doorbetween btid dra drc) $ jsps0J (doorbetween btid dra drc) $
sps0 (doorbetween btid drb drc) sps0 (doorbetween btid drb drc)
where where
doorbetween btid a b = PutSlideDr thedoor (switchWallCol col) --doorbetween btid a b = PutSlideDr thedoor (switchWallCol col)
doorbetween btid a b = PutSlideDr thedoor defaultSwitchWall
(S.fromList (WallObstacle <$> [WallNotAutoOpen,WallBlockVisibility])) 1 a b (S.fromList (WallObstacle <$> [WallNotAutoOpen,WallBlockVisibility])) 1 a b
where where
thedoor = thedoor =
src/Dodge/Placement/Instance/Wall.hs
+3 -5
View File
@@ -1,6 +1,6 @@
module Dodge.Placement.Instance.Wall where module Dodge.Placement.Instance.Wall where
import Color import Dodge.Material.Color
import Control.Lens import Control.Lens
import Data.List import Data.List
import Dodge.Data.GenWorld import Dodge.Data.GenWorld
@@ -11,7 +11,7 @@ import Dodge.Placement.Instance.Block
import Geometry import Geometry
heightWallPS :: PlacementSpot -> Float -> [Point2] -> Placement heightWallPS :: PlacementSpot -> Float -> [Point2] -> Placement
heightWallPS spot h ps = psPtPl spot $ lowBlock Stone (_wlColor defaultWall) h ps heightWallPS spot h ps = psPtPl spot $ lowBlock Stone (materialColor Stone) h ps
invisibleWall :: [Point2] -> Placement invisibleWall :: [Point2] -> Placement
invisibleWall ps = invisibleWall ps =
@@ -89,12 +89,10 @@ baseBlockPane =
{ _wlLine = (V2 0 0, V2 50 0) { _wlLine = (V2 0 0, V2 50 0)
, _wlID = 0 , _wlID = 0
--, _wlColor = greyN 0.5 --, _wlColor = greyN 0.5
, _wlColor = dark $ dark orange -- , _wlColor = dark $ dark orange
--, _wlOpacity = Opaque 10 --, _wlOpacity = Opaque 10
, _wlOpacity = Opaque 17 , _wlOpacity = Opaque 17
, _wlUnshadowed = True , _wlUnshadowed = True
, _wlFireThrough = False
, _wlPenetrable = True
} }
-- TODO find home for this -- TODO find home for this
src/Dodge/Placement/PlaceSpot.hs
+6 -9
View File
@@ -7,7 +7,6 @@
module Dodge.Placement.PlaceSpot (placeSpot) where module Dodge.Placement.PlaceSpot (placeSpot) where
import qualified Data.Set as S import qualified Data.Set as S
import Color
import Control.Monad.State import Control.Monad.State
import Data.Bifunctor import Data.Bifunctor
import Data.Foldable import Data.Foldable
@@ -135,7 +134,7 @@ placeSpotID rid ps pt w = case pt of
PutLS ls -> plNewUpID (gwWorld . cWorld . lWorld . lightSources) lsID (mvLS p' rot ls) w PutLS ls -> plNewUpID (gwWorld . cWorld . lWorld . lightSources) lsID (mvLS p' rot ls) w
RandPS _ -> error "RandPS should not be reachable here" --evaluateRandPS rid rgn ps w RandPS _ -> error "RandPS should not be reachable here" --evaluateRandPS rid rgn ps w
--PutDoor col eo f pss -> plDoor col eo f (map (bimap doShift doShift) pss) w --PutDoor col eo f pss -> plDoor col eo f (map (bimap doShift doShift) pss) w
PutDoor col eo f l p1 p2 -> plDoor col eo f l (pashift p1) (pashift p2) w PutDoor eo f l p1 p2 -> plDoor eo f l (pashift p1) (pashift p2) w
PutCoord cp -> plNewID (gwWorld . coordinates) (doShift cp) w PutCoord cp -> plNewID (gwWorld . coordinates) (doShift cp) w
PutSlideDr wl dr eo off a b -> PutSlideDr wl dr eo off a b ->
plSlideDoor wl dr eo off (doShift a) (doShift b) w plSlideDoor wl dr eo off (doShift a) (doShift b) w
@@ -229,7 +228,7 @@ plTurret ::
plTurret wallpoly mc wl itm p rot gw = plTurret wallpoly mc wl itm p rot gw =
( mcid ( mcid
, gw & gwWorld . cWorld . lWorld . machines %~ addMc , gw & gwWorld . cWorld . lWorld . machines %~ addMc
& gwWorld . cWorld . lWorld . walls %~ placeMachineWalls wl col wallpoly mcid wlid & gwWorld . cWorld . lWorld . walls %~ placeMachineWalls wl wallpoly mcid wlid
& gwWorld . cWorld . lWorld . items . at itid ?~ itm' & gwWorld . cWorld . lWorld . items . at itid ?~ itm'
) )
where where
@@ -237,7 +236,6 @@ plTurret wallpoly mc wl itm p rot gw =
itm & itID .~ NInt itid itm & itID .~ NInt itid
& itLocation .~ OnTurret mcid & itLocation .~ OnTurret mcid
itid = IM.newKey $ gw ^. gwWorld . cWorld . lWorld . items itid = IM.newKey $ gw ^. gwWorld . cWorld . lWorld . items
col = _mcColor mc
mcid = IM.newKey $ gw ^. gwWorld . cWorld . lWorld . machines mcid = IM.newKey $ gw ^. gwWorld . cWorld . lWorld . machines
wlid = IM.newKey $ gw ^. gwWorld . cWorld . lWorld . walls wlid = IM.newKey $ gw ^. gwWorld . cWorld . lWorld . walls
wlids = IS.fromList [wlid .. wlid + length wallpoly - 1] wlids = IS.fromList [wlid .. wlid + length wallpoly - 1]
@@ -252,10 +250,9 @@ plMachine' :: [Point2] -> Machine -> Wall -> Point2 -> Float -> GenWorld -> (Int
plMachine' wallpoly mc wl p rot gw = plMachine' wallpoly mc wl p rot gw =
( mcid ( mcid
, gw & gwWorld . cWorld . lWorld . machines %~ addMc , gw & gwWorld . cWorld . lWorld . machines %~ addMc
& gwWorld . cWorld . lWorld . walls %~ placeMachineWalls wl col wallpoly mcid wlid & gwWorld . cWorld . lWorld . walls %~ placeMachineWalls wl wallpoly mcid wlid
) )
where where
col = _mcColor mc
mcid = IM.newKey $ gw ^. gwWorld . cWorld . lWorld . machines mcid = IM.newKey $ gw ^. gwWorld . cWorld . lWorld . machines
wlid = IM.newKey $ gw ^. gwWorld . cWorld . lWorld . walls wlid = IM.newKey $ gw ^. gwWorld . cWorld . lWorld . walls
wlids = IS.fromList [wlid .. wlid + length wallpoly - 1] wlids = IS.fromList [wlid .. wlid + length wallpoly - 1]
@@ -263,13 +260,13 @@ plMachine' wallpoly mc wl p rot gw =
-- TODO correctly remove/shift pathfinding lines (removePathsCrossing) -- TODO correctly remove/shift pathfinding lines (removePathsCrossing)
placeMachineWalls :: placeMachineWalls ::
Wall -> Color -> [Point2] -> Int -> Int -> IM.IntMap Wall -> IM.IntMap Wall Wall -> [Point2] -> Int -> Int -> IM.IntMap Wall -> IM.IntMap Wall
placeMachineWalls wl col poly mcid wlid = flip (foldr f) $ zip [wlid ..] $ loopPairs poly placeMachineWalls wl poly mcid wlid = flip (foldr f) $ zip [wlid ..] $ loopPairs poly
where where
f (wid, l) = IM.insert wid baseWall{_wlID = wid, _wlLine = l} f (wid, l) = IM.insert wid baseWall{_wlID = wid, _wlLine = l}
baseWall = baseWall =
wl wl
& wlColor .~ col -- & wlColor .~ col
& wlStructure . wsMachine .~ mcid & wlStructure . wsMachine .~ mcid
& wlTouchThrough .~ True & wlTouchThrough .~ True
src/Dodge/Placement/PlaceSpot/TriggerDoor.hs
+3 -4
View File
@@ -15,10 +15,8 @@ import Dodge.Path
import Geometry import Geometry
import qualified IntMapHelp as IM import qualified IntMapHelp as IM
import LensHelp import LensHelp
import Picture
plDoor :: plDoor ::
Color ->
S.Set EdgeObstacle -> S.Set EdgeObstacle ->
-- | Opening condition -- | Opening condition
WdBl -> WdBl ->
@@ -29,7 +27,7 @@ plDoor ::
Point2A -> Point2A ->
GenWorld -> GenWorld ->
(Int, GenWorld) (Int, GenWorld)
plDoor col eo cond l p1 p2 gw = (drid, over gwWorld addWalls $ gw & gwWorld . cWorld . lWorld . doors %~ addDoor) -- carefull with the ordering of addWalls plDoor eo cond l p1 p2 gw = (drid, over gwWorld addWalls $ gw & gwWorld . cWorld . lWorld . doors %~ addDoor) -- carefull with the ordering of addWalls
where where
drid = IM.newKey $ _doors (_lWorld (_cWorld $ _gwWorld gw)) drid = IM.newKey $ _doors (_lWorld (_cWorld $ _gwWorld gw))
addDoor = addDoor =
@@ -45,7 +43,8 @@ plDoor col eo cond l p1 p2 gw = (drid, over gwWorld addWalls $ gw & gwWorld . cW
} }
wlids = take 4 [IM.newKey $ _walls (_lWorld (_cWorld $ _gwWorld gw)) ..] wlids = take 4 [IM.newKey $ _walls (_lWorld (_cWorld $ _gwWorld gw)) ..]
wlps' = rectanglePairs 9 0 (V2 l 0) wlps' = rectanglePairs 9 0 (V2 l 0)
addWalls w' = foldl' (addDoorWall eo drid $ switchWallCol col) w' $ zip wlids --addWalls w' = foldl' (addDoorWall eo drid $ switchWallCol col) w' $ zip wlids
addWalls w' = foldl' (addDoorWall eo drid $ defaultSwitchWall) w' $ zip wlids
$ wlps' & each . each %~ shiftPointBy p1 $ wlps' & each . each %~ shiftPointBy p1
addDoorWall :: S.Set EdgeObstacle addDoorWall :: S.Set EdgeObstacle
src/Dodge/Render/Walls.hs
+10 -8
View File
@@ -1,11 +1,10 @@
module Dodge.Render.Walls ( module Dodge.Render.Walls (wallsToDraw) where
wallsToDraw,
) where
import qualified Control.Foldl as L import qualified Control.Foldl as L
import Control.Lens import Control.Lens
import Dodge.Base.Wall import Dodge.Base.Wall
import Dodge.Data.World import Dodge.Data.World
import Dodge.Material.Color
import Dodge.Wall.Draw import Dodge.Wall.Draw
--import Dodge.Zoning.Base --import Dodge.Zoning.Base
--import Dodge.Zoning.Wall --import Dodge.Zoning.Wall
@@ -14,17 +13,20 @@ import Geometry
import ShapePicture import ShapePicture
-- not necessary: should just poke all walls to their wanted places -- not necessary: should just poke all walls to their wanted places
wallsToDraw :: World -> ( [((Point2, Point2), Point4)], SPic, [Wall]) wallsToDraw :: World -> ([((Point2, Point2), Point4)], SPic, [Wall])
wallsToDraw w = L.fold wallsToDraw w =
L.fold
( (,,) ( (,,)
<$>L.prefilter wlSeeThroughDraw (L.premap f L.list) <$> L.prefilter wlSeeThroughDraw (L.premap f L.list)
<*> L.premap getWallSPic L.mconcat <*> L.premap getWallSPic L.mconcat
<*> L.prefilter wlOpaqueDraw L.list <*> L.prefilter wlOpaqueDraw L.list
) )
(w ^. cWorld . lWorld . walls) (w ^. cWorld . lWorld . walls)
-- (wlsFromIXs w $ zonesExtract (w ^. wlZoning) $ zoneOfSight wlZoneSize cam)
where where
f wl = (_wlLine wl, _wlColor wl) -- (wlsFromIXs w $ zonesExtract (w ^. wlZoning) $ zoneOfSight wlZoneSize cam)
f wl = (_wlLine wl, materialColor $ _wlMaterial wl)
-- cam = w ^. cWorld . camPos -- cam = w ^. cWorld . camPos
--wallsToDraw --wallsToDraw
src/Dodge/Room/Airlock.hs
+13 -13
View File
@@ -51,7 +51,8 @@ decontamRoom i =
return $ return $
putDoubleDoor putDoubleDoor
switchWallObs switchWallObs
(switchWallCol red) --(switchWallCol red)
defaultSwitchWall
(cond pmnt) (cond pmnt)
(V2 (-10) 35) (V2 (-10) 35)
(V2 (-10) 65) (V2 (-10) 65)
@@ -60,7 +61,8 @@ decontamRoom i =
mcpos = V2 70 50 mcpos = V2 70 50
cutps = [rectNSWE 100 0 0 40, switchcut] cutps = [rectNSWE 100 0 0 40, switchcut]
ps = (\p -> p - mcpos) <$> orderPolygon (concat cutps) ps = (\p -> p - mcpos) <$> orderPolygon (concat cutps)
thewall = switchWallCol col --thewall = switchWallCol col
thewall = defaultSwitchWall
switchcut = rectNSWE 65 35 (-40) 80 switchcut = rectNSWE 65 35 (-40) 80
lnks = lnks =
[ (V2 20 95, 0) [ (V2 20 95, 0)
@@ -87,7 +89,8 @@ airlock0 =
, _rmBound = [rectNSWE 75 15 0 40, switchcut] , _rmBound = [rectNSWE 75 15 0 40, switchcut]
} }
where where
thewall = switchWallCol col --thewall = switchWallCol col
thewall = defaultSwitchWall
switchcut = rectNSWE 65 35 (-40) 20 switchcut = rectNSWE 65 35 (-40) 20
lnks = lnks =
[ (V2 20 95, 0) [ (V2 20 95, 0)
@@ -96,13 +99,12 @@ airlock0 =
col = dim $ dim $ bright red col = dim $ dim $ bright red
--airlockDoor :: Color -> WdBl -> [(Point2, Point2)] -> PSType --airlockDoor :: Color -> WdBl -> [(Point2, Point2)] -> PSType
airlockDoor :: Color -> WdBl -> Float -> Point2A -> Point2A -> PSType airlockDoor :: WdBl -> Float -> Point2A -> Point2A -> PSType
airlockDoor col = PutDoor col switchWallObs airlockDoor = PutDoor switchWallObs
airlockDoubleDoor :: airlockDoubleDoor ::
Point2 -> Point2 ->
Point2 -> Point2 ->
Color ->
WdBl -> WdBl ->
Float -> Float ->
Point2A -> Point2A ->
@@ -111,9 +113,9 @@ airlockDoubleDoor ::
Point2A -> Point2A ->
Point2A -> Point2A ->
Maybe Placement Maybe Placement
airlockDoubleDoor p1 p2 col cond l1 x1 y1 l2 x2 y2 = airlockDoubleDoor p1 p2 cond l1 x1 y1 l2 x2 y2 =
jspsJ p1 0 (airlockDoor col cond l1 x1 y1) $ jspsJ p1 0 (airlockDoor cond l1 x1 y1) $
sPS p2 0 (airlockDoor col cond l2 x2 y2) sPS p2 0 (airlockDoor cond l2 x2 y2)
airlockSimple :: Room airlockSimple :: Room
airlockSimple = airlockSimple =
@@ -128,7 +130,6 @@ airlockSimple =
airlockDoubleDoor airlockDoubleDoor
0 0
(V2 180 0) (V2 180 0)
col
(WdBlBtOn btid) (WdBlBtOn btid)
l1 l1
x1 x1
@@ -173,7 +174,6 @@ airlockZ = do
airlockDoubleDoor airlockDoubleDoor
(V2 0 60) (V2 0 60)
(V2 180 60) (V2 180 60)
col
(WdBlBtOn btid) (WdBlBtOn btid)
l1 l1
x1 x1
@@ -222,7 +222,7 @@ airlock90 =
[ pContID [ pContID
(PS (V2 120 120) (3 * pi / 4)) (PS (V2 120 120) (3 * pi / 4))
(PutButton $ makeSwitch col red NoWorldEffect NoWorldEffect) (PutButton $ makeSwitch col red NoWorldEffect NoWorldEffect)
$ \btid -> jsps (V2 5 5) 0 $ airlockDoor col (WdBlBtOn btid) l1 x1 y1 $ \btid -> jsps (V2 5 5) 0 $ airlockDoor (WdBlBtOn btid) l1 x1 y1
, mntLS vShape (V2 35 35) (V3 70 70 50) , mntLS vShape (V2 35 35) (V3 70 70 50)
] ]
, _rmBound = , _rmBound =
@@ -256,7 +256,7 @@ airlockCrystal =
[ pContID [ pContID
(PS (V2 145 70) (pi / 2)) (PS (V2 145 70) (pi / 2))
(PutButton $ makeSwitch col red NoWorldEffect NoWorldEffect) (PutButton $ makeSwitch col red NoWorldEffect NoWorldEffect)
$ \btid -> jsps (V2 40 70) 0 $ airlockDoor col (WdBlBtOn btid) l1 x1 y1 $ \btid -> jsps (V2 40 70) 0 $ airlockDoor (WdBlBtOn btid) l1 x1 y1
, crystalLine (V2 0 70) (V2 40 70) , crystalLine (V2 0 70) (V2 40 70)
, mntLS vShape (V2 150 70) (V3 110 70 70) , mntLS vShape (V2 150 70) (V3 110 70 70)
] ]
src/Dodge/Room/Door.hs
+2 -2
View File
@@ -1,7 +1,6 @@
{- Rooms that connect other rooms, blocking sight. -} {- Rooms that connect other rooms, blocking sight. -}
module Dodge.Room.Door where module Dodge.Room.Door where
import Color
import Data.Maybe import Data.Maybe
import Dodge.Data.GenWorld import Dodge.Data.GenWorld
import Dodge.Default.Door import Dodge.Default.Door
@@ -43,5 +42,6 @@ triggerDoorRoom i =
f gw = fromMaybe (error "tried to put a door using an empty placement list") $ do f gw = fromMaybe (error "tried to put a door using an empty placement list") $ do
pmnt <- gw ^? genPmnt . ix i pmnt <- gw ^? genPmnt . ix i
return $ putDoubleDoor return $ putDoubleDoor
switchWallObs (switchWallCol red) (cond pmnt) (V2 0 20) (V2 40 20) 2 --switchWallObs (switchWallCol red) (cond pmnt) (V2 0 20) (V2 40 20) 2
switchWallObs defaultSwitchWall (cond pmnt) (V2 0 20) (V2 40 20) 2
cond pmnt = WdTrig $ fromJust (_plMID pmnt) cond pmnt = WdTrig $ fromJust (_plMID pmnt)
src/Dodge/Room/LongDoor.hs
+4 -2
View File
@@ -57,7 +57,8 @@ twinSlowDoorRoom w h x =
, _rmViewpoints = [V2 0 h] , _rmViewpoints = [V2 0 h]
} }
where where
thewall = switchWallCol red --thewall = switchWallCol red
thewall = defaultSwitchWall
wlSpeed = 0.5 wlSpeed = 0.5
addColorChange lsid drid = addColorChange lsid drid =
over prUpdate $ over prUpdate $
@@ -129,7 +130,8 @@ addButtonSlowDoor x h rm = do
.++~ [MountedLS (fromJust $ _plMID plls), MountedProp (fromJust $ _plMID plpr)] .++~ [MountedLS (fromJust $ _plMID plls), MountedProp (fromJust $ _plMID plpr)]
-- TODO make the height of this light source and of other mounted lights -- TODO make the height of this light source and of other mounted lights
-- be taken from a single consistent source -- be taken from a single consistent source
thewall = switchWallCol red --thewall = switchWallCol red
thewall = defaultSwitchWall
butDoor = putLitButOnPos butDoor = putLitButOnPos
col col
(rprBool (isUnusedLnkType InLink)) (rprBool (isUnusedLnkType InLink))
src/Dodge/Room/Procedural.hs
+2 -1
View File
@@ -330,7 +330,8 @@ centerVaultRoom w h d =
jspsJ (V2 0 (d -10)) 0 (PutSlideDr (thedoor btid) thewall switchWallObs 1 (V2 (-21) 0) (V2 0 0)) $ jspsJ (V2 0 (d -10)) 0 (PutSlideDr (thedoor btid) thewall switchWallObs 1 (V2 (-21) 0) (V2 0 0)) $
sPS (V2 0 (d -10)) 0 (PutSlideDr (thedoor btid) thewall switchWallObs 1 (V2 21 0) (V2 0 0)) sPS (V2 0 (d -10)) 0 (PutSlideDr (thedoor btid) thewall switchWallObs 1 (V2 21 0) (V2 0 0))
] ]
thewall = switchWallCol col --thewall = switchWallCol col
thewall = defaultSwitchWall
thedoor btid = thedoor btid =
defaultDoor defaultDoor
& drTrigger .~ WdBlBtOn btid & drTrigger .~ WdBlBtOn btid
src/Dodge/Wall/Draw.hs
+4 -1
View File
@@ -1,8 +1,10 @@
module Dodge.Wall.Draw (drawWall) where module Dodge.Wall.Draw (drawWall) where
import Dodge.Material.Color
import Dodge.Data.Wall import Dodge.Data.Wall
import Picture.Base import Picture.Base
import ShapePicture import ShapePicture
import Control.Lens
drawWall :: WallDraw -> Wall -> SPic drawWall :: WallDraw -> Wall -> SPic
drawWall wd = case wd of drawWall wd = case wd of
@@ -11,7 +13,8 @@ drawWall wd = case wd of
drawForceField :: Wall -> SPic drawForceField :: Wall -> SPic
drawForceField wl = noShape . setLayer BloomLayer drawForceField wl = noShape . setLayer BloomLayer
. setDepth 20 . setDepth 20
. color (_wlColor wl) . color (materialColor (wl ^. wlMaterial))
-- . color (_wlColor wl)
$ thickLine 5 [a, b] $ thickLine 5 [a, b]
where where
(a, b) = _wlLine wl (a, b) = _wlLine wl
src/Dodge/Wall/ForceField.hs
+2 -5
View File
@@ -1,17 +1,14 @@
module Dodge.Wall.ForceField where module Dodge.Wall.ForceField where
import Color
import Dodge.Data.Wall import Dodge.Data.Wall
import Dodge.Default.Wall import Dodge.Default.Wall
forceField :: Wall forceField :: Wall
forceField = forceField =
defaultWall defaultWall
{ _wlColor = orange { _wlOpacity = DrawnWall DrawForceField
, _wlOpacity = DrawnWall DrawForceField
, _wlWalkable = True
, _wlFireThrough = False
, _wlUnshadowed = True , _wlUnshadowed = True
, _wlRotateTo = False , _wlRotateTo = False
, _wlStructure = StandaloneWall , _wlStructure = StandaloneWall
, _wlMaterial = ForceField
} }
src/Dodge/WallCreatureCollisions.hs
+4 -2
View File
@@ -47,7 +47,8 @@ colCrWall w c
p2 = c ^. crPos . _xy p2 = c ^. crPos . _xy
ls = _wlLine <$> wls ls = _wlLine <$> wls
ls' = filter (uncurry $ isLHS p1) ls ls' = filter (uncurry $ isLHS p1) ls
wls = filter (not . _wlWalkable) $ wlsNearRect (p2 +.+ V2 r r) (p2 -.- V2 r r) w wls = filter notff $ wlsNearRect (p2 +.+ V2 r r) (p2 -.- V2 r r) w
notff x = x ^. wlMaterial /= ForceField
-- the amount to push creatures out from walls, extra to their radius -- the amount to push creatures out from walls, extra to their radius
wallBuffer :: Float wallBuffer :: Float
@@ -88,9 +89,10 @@ pushOrCrush wls cr = case mapMaybe (pushOutFromWall (crRad (cr ^. crType)) cpos)
crOnWall :: Creature -> World -> Bool crOnWall :: Creature -> World -> Bool
crOnWall cr = crOnWall cr =
any (uncurry (circOnSeg p r) . _wlLine) any (uncurry (circOnSeg p r) . _wlLine)
. filter (not . _wlWalkable) . filter notff
. wlsNearPoint p . wlsNearPoint p
where where
notff x = x ^. wlMaterial /= ForceField
p = cr ^. crPos . _xy p = cr ^. crPos . _xy
r = crRad (cr ^. crType) r = crRad (cr ^. crType)