Add possible cosmetic pipes to tanks
This commit is contained in:
@@ -11,11 +11,13 @@ module Dodge.Base
|
||||
, module Dodge.Base.Window
|
||||
, module Dodge.Base.Coordinate
|
||||
, module Dodge.Base.Collide
|
||||
, module Dodge.Base.CardinalPoint
|
||||
) where
|
||||
import Dodge.Data
|
||||
import Dodge.Base.WinScale
|
||||
import Dodge.Base.NewID
|
||||
import Dodge.Base.Coordinate
|
||||
import Dodge.Base.CardinalPoint
|
||||
import Dodge.Zone
|
||||
--import Dodge.Zone.Data
|
||||
import Dodge.Base.Window
|
||||
|
||||
@@ -0,0 +1,15 @@
|
||||
module Dodge.Base.CardinalPoint where
|
||||
import Dodge.Data.Room
|
||||
import Geometry
|
||||
|
||||
cardList :: [CardinalPoint]
|
||||
cardList = [North,East,South,West]
|
||||
|
||||
cardVec :: CardinalPoint -> Point2
|
||||
cardVec cp = case cp of
|
||||
North -> V2 0 1
|
||||
South -> V2 0 (-1)
|
||||
East -> V2 1 0
|
||||
West -> V2 (-1) 0
|
||||
|
||||
|
||||
+2
-2
@@ -924,7 +924,7 @@ data Block = Block
|
||||
, _blShadows :: [Int] -- a list of blocks/walls? that are not shown when this block exists
|
||||
, _blFootprint :: [Point2]
|
||||
, _blPos :: Point2
|
||||
, _blRot :: Float
|
||||
, _blDir :: Float
|
||||
, _blDraw :: Block -> SPic
|
||||
, _blDeath :: Block -> World -> World
|
||||
}
|
||||
@@ -1402,7 +1402,7 @@ data PSType = PutCrit {_unPutCrit :: Creature}
|
||||
| PutTerminal {_unputTerminal :: Terminal}
|
||||
| PutFlIt Item
|
||||
| PutPPlate PressPlate
|
||||
| PutBlock Block Wall [Point2]
|
||||
| PutBlock {_putBlock :: Block, _putWall :: Wall, _putPoly :: [Point2] }
|
||||
| PutCoord Point2
|
||||
| PutMod Modification
|
||||
| PutTrigger (World -> Bool)
|
||||
|
||||
@@ -11,7 +11,7 @@ defaultBlock = Block
|
||||
, _blShadows = []
|
||||
, _blFootprint = []
|
||||
, _blPos = 0
|
||||
, _blRot = 0
|
||||
, _blDir = 0
|
||||
, _blDraw = const mempty
|
||||
, _blDeath = makeBlockDebris
|
||||
}
|
||||
|
||||
+3
-2
@@ -40,9 +40,10 @@ initialAnoTree :: Annotation
|
||||
initialAnoTree = OnwardList
|
||||
$ intersperse (AnTree corDoor)
|
||||
-- [ IntAnno $ AnTree . startRoom
|
||||
[ AnRoom $ tanksRoom [] []
|
||||
, AnRoom roomPillarsPassage
|
||||
[ AnRoom tanksPipesRoom
|
||||
, AnRoom tanksPipesRoom
|
||||
, AnRoom $ tanksRoom [] []
|
||||
, AnRoom roomPillarsPassage
|
||||
, AnTree firstBreather
|
||||
-- , (SpecificRoom . return . tToBTree $ treePost [corridor,corridor,cleatOnward corridor])
|
||||
, AnRoom $ roomCCrits 10
|
||||
|
||||
@@ -1,5 +1,12 @@
|
||||
module Dodge.Placement.Instance.Pipe where
|
||||
import Shape
|
||||
import Geometry
|
||||
import Quaternion
|
||||
|
||||
verticalPipe :: Float -> Shape
|
||||
verticalPipe = flip upperPrismPoly $ polyCirc 4 5
|
||||
verticalPipe = flip upperPrismPoly $ polyCirc 2 5
|
||||
|
||||
horPipe :: Float -> Point2 -> Point2 -> Shape
|
||||
horPipe h x y = translateSH (x `v2z` h) $ overPosSH (rotateToZ (V3 xd yd 0)) $ verticalPipe (dist x y)
|
||||
where
|
||||
V2 xd yd = x -.- y
|
||||
|
||||
@@ -26,7 +26,7 @@ tankShape baseshape facade col col'
|
||||
= sps0 $ PutBlock bl wl $ reverse baseshape
|
||||
where
|
||||
bl = defaultBlock
|
||||
& blDraw .~ (\bl' -> (noPic $ uncurryV translateSHf (_blPos bl') $ rotateSH (_blRot bl') $ colorSH col (upperPrismPoly 31 $ reverse baseshape) <> facade col col'))
|
||||
& blDraw .~ const (noPic $ colorSH col (upperPrismPoly 31 $ reverse baseshape) <> facade col col')
|
||||
& blDeath .~ const id
|
||||
wl = defaultWall
|
||||
& wlDraw .~ False
|
||||
|
||||
@@ -103,7 +103,7 @@ placeSpotID ps pt w = case pt of
|
||||
PutCoord cp -> plNewID coordinates (doShift cp) w
|
||||
PutSlideDr pth col f off a b spd
|
||||
-> plSlideDoor pth col f off (doShift a) (doShift b) spd w
|
||||
PutBlock bl wl ps' -> placeBlock (map doShift ps') (bl & blPos %~ doShift & blRot .~ rot)
|
||||
PutBlock bl wl ps' -> placeBlock (map doShift ps') (bl & blPos %~ doShift & blDir .~ rot)
|
||||
wl w
|
||||
PutLineBlock wl wdth dpth a b -> placeLineBlock wl wdth dpth (doShift a) (doShift b) w
|
||||
PutWall qs wl -> (0,placeWallPoly (map doShift qs) wl w)
|
||||
|
||||
@@ -85,7 +85,7 @@ placeLineBlock basePane blockWidth depth a b gw = ( 0
|
||||
insertBlock (i,p) = over blocks $ IM.insert (i+blid) Block
|
||||
{ _blID = i + blid, _blWallIDs = IS.fromList $ ksAtI i
|
||||
, _blHP = 1000, _blShadows = shadowsAt i
|
||||
, _blRot = 0 -- THIS IS NOT SENSIBLE. TODO rethink block positioning
|
||||
, _blDir = 0 -- THIS IS NOT SENSIBLE. TODO rethink block positioning
|
||||
, _blFootprint = cornersAt p -- TODO check winding (clockwise, anticlockwise)
|
||||
, _blPos = p, _blDraw = const mempty , _blDeath = makeBlockDebris}
|
||||
insertBlocks = flip (foldr insertBlock) $ zip is blockCenPs
|
||||
|
||||
@@ -3,6 +3,7 @@ module Dodge.PlacementSpot
|
||||
( atFstLnkOut
|
||||
, rpIsOnPath
|
||||
, rpIsOffPath
|
||||
, rpOffPathEdge
|
||||
, useUnusedLnk
|
||||
, psRandRanges
|
||||
, useRoomPosCond
|
||||
@@ -80,6 +81,10 @@ rpIsOffPath = any f . _rpType
|
||||
where
|
||||
f RoomPosOffPath {} = True
|
||||
f _ = False
|
||||
rpOffPathEdge :: PathEdge -> RoomPos -> Bool
|
||||
rpOffPathEdge pe = any f . _rpType
|
||||
where
|
||||
f rt = maybe False (any (== pe)) (rt ^? offPathEdges)
|
||||
|
||||
resetPLUse :: PlacementSpot -> PlacementSpot
|
||||
resetPLUse (PSPos f g fallback) = PSPos f' g fallback
|
||||
|
||||
@@ -33,7 +33,7 @@ worldSPic :: Configuration -> World -> SPic
|
||||
worldSPic cfig w =
|
||||
(extraShapes w, extraPics cfig w)
|
||||
<> foldMap (dbArg _prDraw) (filtOn _prPos _props)
|
||||
<> foldMap (dbArg _blDraw) (filtOn _blPos _blocks)
|
||||
<> foldMap (shiftDraw _blPos _blDir _blDraw) (filtOn _blPos _blocks)
|
||||
<> foldMap (dbArg _cpPict) (filtOn _cpPos _corpses)
|
||||
<> foldMap ((($ w) . ($ cfig)) . dbArg _crPict) (filtOn _crPos _creatures)
|
||||
<> foldMap floorItemSPic (filtOn _flItPos _floorItems)
|
||||
@@ -43,6 +43,12 @@ worldSPic cfig w =
|
||||
filtOn f g = IM.filter (pointIsClose . f) (g w)
|
||||
pointIsClose = cullPoint cfig w
|
||||
|
||||
shiftDraw :: (a -> Point2) -> (a -> Float) -> (a -> a -> SPic) -> a -> SPic
|
||||
shiftDraw fpos fdir fdraw x = uncurryV translateSPf (fpos x)
|
||||
. rotateSP (fdir x)
|
||||
$ fdraw x x
|
||||
|
||||
|
||||
cullPoint :: Configuration -> World -> Point2 -> Bool
|
||||
cullPoint cfig w p
|
||||
| debugOn Close_shape_culling cfig = pointInPolygon p (_boundBox w)
|
||||
|
||||
@@ -119,7 +119,8 @@ lnkBothAnd rlt ltcon ltcon2 i (j,(p,a)) = RoomLink
|
||||
roomRectAutoLinks :: Float -> Float -> Room
|
||||
roomRectAutoLinks x y = roomRect x y (f x) (f y)
|
||||
& rmName .~ "autoRect"
|
||||
& rmPmnts .~ [mntLightLnkCond $ resetPLUse $ rprBool $ \rp _ -> isInLnk rp]
|
||||
& rmPmnts .~ [mntLightLnkCond $ resetPLUse $ rprBool $ \rp _ -> isInLnk rp
|
||||
,mntLightLnkCond $ resetPLUse $ rprBool $ \rp _ -> isOutLnk rp]
|
||||
where
|
||||
f z = max 1 $ (ceiling z - 40) `div` 60
|
||||
{- Combines two rooms into one room.
|
||||
|
||||
+22
-5
@@ -1,5 +1,6 @@
|
||||
module Dodge.Room.Tanks where
|
||||
import Dodge.Data
|
||||
import Dodge.Placement.Instance.Pipe
|
||||
import Dodge.LevelGen.Data
|
||||
import RandomHelp
|
||||
import Dodge.Room.Procedural
|
||||
@@ -9,11 +10,13 @@ import Dodge.Room.Modify.Girder
|
||||
import Dodge.Placement.Instance
|
||||
import Dodge.Placement.TopDecoration
|
||||
import Dodge.PlacementSpot
|
||||
import Dodge.Base.CardinalPoint
|
||||
--import Padding
|
||||
import Color
|
||||
--import Shape
|
||||
import Shape
|
||||
import ShapePicture
|
||||
import LensHelp
|
||||
--import Geometry
|
||||
import Geometry
|
||||
|
||||
--import Data.Maybe
|
||||
--import Data.Tree
|
||||
@@ -29,11 +32,25 @@ randomTank = takeOne $ map (\f -> f (dim orange) orange)
|
||||
, tankSquareDec plusDecoration
|
||||
]
|
||||
|
||||
randEdgeTank :: RandomGen g => State g Placement
|
||||
randEdgeTank = do
|
||||
edge <- takeOne cardList
|
||||
basetank <- randomTank
|
||||
return $ basetank
|
||||
& plType . putBlock . blDraw
|
||||
%~ fmap (<> noPic ( colorSH orange (verticalPipe 80
|
||||
<> horPipe 80 0 (70 *.* cardVec edge))))
|
||||
-- 70 is a guess, the true value depends on the distance to the wall
|
||||
& plSpot .~ rprBool (\rp _ -> _rpPlacementUse rp == 0
|
||||
&& rpOffPathEdge (PathFromEdge edge 0) rp)
|
||||
|
||||
tanksPipesRoom :: RandomGen g => State g Room
|
||||
tanksPipesRoom = do
|
||||
thetank <- randomTank
|
||||
let rm = roomRectAutoLinks 200 400 & rmPmnts .:~ thetank
|
||||
return rm
|
||||
w <- state $ randomR (200,400)
|
||||
h <- state $ randomR (200,400)
|
||||
i <- state $ randomR (1,5)
|
||||
tanks <- replicateM i randEdgeTank
|
||||
return $ roomRectAutoLinks w h & rmPmnts .++~ tanks
|
||||
|
||||
tanksRoom :: RandomGen g => [Creature] -> [Item] -> State g Room
|
||||
tanksRoom crs its = do
|
||||
|
||||
Reference in New Issue
Block a user