diff --git a/src/Dodge/Base.hs b/src/Dodge/Base.hs index 355338baf..e9e1d1afb 100644 --- a/src/Dodge/Base.hs +++ b/src/Dodge/Base.hs @@ -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 diff --git a/src/Dodge/Base/CardinalPoint.hs b/src/Dodge/Base/CardinalPoint.hs new file mode 100644 index 000000000..68bac1871 --- /dev/null +++ b/src/Dodge/Base/CardinalPoint.hs @@ -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 + + diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index 40d0b9524..f919750e0 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -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) diff --git a/src/Dodge/Default/Block.hs b/src/Dodge/Default/Block.hs index 345a1a74c..8d5941d77 100644 --- a/src/Dodge/Default/Block.hs +++ b/src/Dodge/Default/Block.hs @@ -11,7 +11,7 @@ defaultBlock = Block , _blShadows = [] , _blFootprint = [] , _blPos = 0 - , _blRot = 0 + , _blDir = 0 , _blDraw = const mempty , _blDeath = makeBlockDebris } diff --git a/src/Dodge/Floor.hs b/src/Dodge/Floor.hs index c84dcdc65..3ea12ed5f 100644 --- a/src/Dodge/Floor.hs +++ b/src/Dodge/Floor.hs @@ -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 diff --git a/src/Dodge/Placement/Instance/Pipe.hs b/src/Dodge/Placement/Instance/Pipe.hs index 5406cd0a1..42f7ddf69 100644 --- a/src/Dodge/Placement/Instance/Pipe.hs +++ b/src/Dodge/Placement/Instance/Pipe.hs @@ -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 diff --git a/src/Dodge/Placement/Instance/Tank.hs b/src/Dodge/Placement/Instance/Tank.hs index 02dc24061..3238e5f59 100644 --- a/src/Dodge/Placement/Instance/Tank.hs +++ b/src/Dodge/Placement/Instance/Tank.hs @@ -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 diff --git a/src/Dodge/Placement/PlaceSpot.hs b/src/Dodge/Placement/PlaceSpot.hs index fa2bec9e1..4e8433c44 100644 --- a/src/Dodge/Placement/PlaceSpot.hs +++ b/src/Dodge/Placement/PlaceSpot.hs @@ -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) diff --git a/src/Dodge/Placement/PlaceSpot/Block.hs b/src/Dodge/Placement/PlaceSpot/Block.hs index c582f03a8..d7a8ce480 100644 --- a/src/Dodge/Placement/PlaceSpot/Block.hs +++ b/src/Dodge/Placement/PlaceSpot/Block.hs @@ -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 diff --git a/src/Dodge/PlacementSpot.hs b/src/Dodge/PlacementSpot.hs index 5cf2a2185..adb4bbb16 100644 --- a/src/Dodge/PlacementSpot.hs +++ b/src/Dodge/PlacementSpot.hs @@ -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 diff --git a/src/Dodge/Render/ShapePicture.hs b/src/Dodge/Render/ShapePicture.hs index bf58df797..d21005aca 100644 --- a/src/Dodge/Render/ShapePicture.hs +++ b/src/Dodge/Render/ShapePicture.hs @@ -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) diff --git a/src/Dodge/Room/Procedural.hs b/src/Dodge/Room/Procedural.hs index e0e80f500..7d657d715 100644 --- a/src/Dodge/Room/Procedural.hs +++ b/src/Dodge/Room/Procedural.hs @@ -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. diff --git a/src/Dodge/Room/Tanks.hs b/src/Dodge/Room/Tanks.hs index fad50cabb..b5f8ce9e5 100644 --- a/src/Dodge/Room/Tanks.hs +++ b/src/Dodge/Room/Tanks.hs @@ -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