diff --git a/src/Bound.hs b/src/Bound.hs index 708020eea..9a9ad8e29 100644 --- a/src/Bound.hs +++ b/src/Bound.hs @@ -6,6 +6,7 @@ import Streaming import qualified Streaming.Prelude as S import qualified Control.Foldl as L +-- NSEW boundPoints :: Stream (Of Point2) Identity () -> Maybe (Float,Float,Float,Float) {-# INLINE boundPoints #-} boundPoints = f . runIdentity . L.purely S.fold_ ((,,,) diff --git a/src/Dodge/Block.hs b/src/Dodge/Block.hs index 560e1851a..589d8a57b 100644 --- a/src/Dodge/Block.hs +++ b/src/Dodge/Block.hs @@ -2,7 +2,7 @@ module Dodge.Block where import Dodge.Data import Dodge.Base.Collide import Dodge.Material ---import Dodge.Block.Debris +import Dodge.Block.Debris import Dodge.Zone import Dodge.Wall.Zone import Dodge.WorldEvent.Sound @@ -46,7 +46,7 @@ checkBlockHP bl destroyBlock :: Block -> World -> World destroyBlock bl w = w & flip (foldr unshadowBlock) (_blShadows bl) - & _blDeath bl bl + & makeBlockDebris bl & deleteWallIDs wlids & maybeClearPaths (_blObstructs bl) -- must happen after the walls are deleted & blocks %~ IM.delete (_blID bl) diff --git a/src/Dodge/Block/Debris.hs b/src/Dodge/Block/Debris.hs index fa5761647..ad57dd2b7 100644 --- a/src/Dodge/Block/Debris.hs +++ b/src/Dodge/Block/Debris.hs @@ -12,6 +12,7 @@ import Geometry import Color import LensHelp import RandomHelp +import Grid import qualified Quaternion as Q import qualified Data.IntSet as IS @@ -29,16 +30,46 @@ makeDoorDebris dr w = w & makeDebris mt col p return (_wlMaterial wl,_wlColor wl) makeBlockDebris :: Block -> World -> World -makeBlockDebris bl w = w & makeDebris mt col (_blPos bl) +--makeBlockDebris bl w = w & makeDebris mt col (_blPos bl) +makeBlockDebris bl w = foldr (makeDebris mt col) w ps where + dsize = debrisSize mt + ps = gridInPolygon dsize $ shrinkPolyOnEdges dsize $ reverse (_blFootprint bl) (mt,col) = fromMaybe (Stone,greyN 0.5) $ do wlids <- w ^? blocks . ix (_blID bl) . blWallIDs (wlid,_) <- IS.minView wlids wl <- w ^? walls . ix wlid return (_wlMaterial wl,_wlColor wl) +makeDebrisToHeight :: Float -> Material -> Color -> Point2 -> World -> World +makeDebrisToHeight = makeDebrisDirectedHeight 1 2 (2*pi) 0 + makeDebris :: Material -> Color -> Point2 -> World -> World makeDebris = makeDebrisDirected 1 2 (2*pi) 0 + +makeDebrisDirectedHeight :: Float -> Float -> Float -> Float -> Float -> Material + -> Color -> Point2 -> World -> World +makeDebrisDirectedHeight mindist maxdist arcrad dir maxh bm col p w = w + & flip (foldl' (flip $ plNew props pjID)) thedebris + & randGen .~ newg + & originsIDsAt [MaterialSound bm i | i <- [0,1,2]] (destroyMatS bm) p + where + dsize = debrisSize bm + (thedebris,newg) = mapM f [10,10 + dsize ..maxh+5] & runState $ _randGen w + f h = do + v <- rotateV (dir - arcrad/2) <$> randInArcStrip mindist maxdist arcrad + q <- Q.vToQuat (V3 0 0 1) <$> randOnUnitSphere + spinspeed <- randomR (-0.2,-0.1) & state + basedebris <- baseDebris bm + return $ basedebris + & pjColor .~ col + & prPos .~ p + & pjVel .~ v + & pjQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) spinspeed + & pjQuat .~ q + & pjVelZ .~ 0 + & pjPosZ .~ h + makeDebrisDirected :: Float -> Float -> Float @@ -67,6 +98,15 @@ makeDebrisDirected mindist maxdist arcrad dir bm col p w = w & pjVelZ .~ 0 & pjPosZ .~ h +debrisSize :: Material -> Float +debrisSize mt = case mt of + Stone -> 20 + Glass -> 10 + Crystal -> 10 + Dirt -> 20 + Wood -> 10 + Metal -> 10 + baseDebris :: Material -> State StdGen Prop baseDebris mt = case mt of Stone -> return stoneDebris diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index 1b4688af4..eaa656732 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -989,7 +989,6 @@ data Block = Block , _blHeight :: Float , _blMaterial :: Material , _blDraw :: Block -> SPic - , _blDeath :: Block -> World -> World , _blObstructs :: [(Int,Int,PathEdge)] } data TerminalStatus = TerminalOff | TerminalBusy | TerminalReady diff --git a/src/Dodge/Default/Block.hs b/src/Dodge/Default/Block.hs index 2754f8327..a6d919b64 100644 --- a/src/Dodge/Default/Block.hs +++ b/src/Dodge/Default/Block.hs @@ -1,6 +1,5 @@ module Dodge.Default.Block where import Dodge.Data -import Dodge.Block.Debris import LensHelp defaultBlock :: Block @@ -13,7 +12,6 @@ defaultBlock = Block , _blPos = 0 , _blDir = 0 , _blDraw = const mempty - , _blDeath = makeBlockDebris , _blHeight = 100 , _blMaterial = Stone , _blObstructs = [] diff --git a/src/Dodge/Floor.hs b/src/Dodge/Floor.hs index ecf5b6ba7..71d6e8b53 100644 --- a/src/Dodge/Floor.hs +++ b/src/Dodge/Floor.hs @@ -41,6 +41,7 @@ initialAnoTree :: Annotation initialAnoTree = OnwardList $ intersperse (AnTree corDoor) [ IntAnno $ AnTree . startRoom + , AnRoom $ tanksRoom [] [] , AnRoom $ roomCCrits 0 , AnRoom $ return airlock0 , AnRoom slowDoorRoom diff --git a/src/Dodge/Placement/Instance/Block.hs b/src/Dodge/Placement/Instance/Block.hs index 5d0b78f81..b08870031 100644 --- a/src/Dodge/Placement/Instance/Block.hs +++ b/src/Dodge/Placement/Instance/Block.hs @@ -13,7 +13,6 @@ decoratedBlock decf mat col h ps = PutBlock bl wl $ reverse ps where bl = defaultBlock & blDraw .~ (\bl' -> noPic (colorSH col (upperPrismPoly h $ reverse ps) <> decf bl')) - & blDeath .~ const id & blHeight .~ h & blMaterial .~ mat wl = defaultWall diff --git a/src/Dodge/Placement/PlaceSpot/Block.hs b/src/Dodge/Placement/PlaceSpot/Block.hs index 17c8e8f38..191c50f06 100644 --- a/src/Dodge/Placement/PlaceSpot/Block.hs +++ b/src/Dodge/Placement/PlaceSpot/Block.hs @@ -6,8 +6,6 @@ module Dodge.Placement.PlaceSpot.Block where import Dodge.Data import Dodge.Path -import Dodge.Block.Debris ---import Dodge.LevelGen.LevelStructure import Dodge.Base --import Dodge.Zone import Geometry @@ -76,7 +74,7 @@ plLineBlock basePane blwidth a b gw = ( 0 , _blObstructs = [] , _blMaterial = _wlMaterial basePane , _blHeight = 100 - , _blPos = p, _blDraw = const mempty , _blDeath = makeBlockDebris} + , _blPos = p, _blDraw = const mempty } ) insertBlocks = flip (foldr insertBlock) $ zip is blockCenPs ksAtI i = map ( + (wlid + i*4) ) [0,1,2,3] diff --git a/src/Dodge/Room/Path.hs b/src/Dodge/Room/Path.hs index 1d2ed3879..3d8f50f8a 100644 --- a/src/Dodge/Room/Path.hs +++ b/src/Dodge/Room/Path.hs @@ -12,12 +12,11 @@ import Dodge.Data import Dodge.LevelGen.StaticWalls import Dodge.RoomLink import Geometry +import Grid import Data.Function (on) import Data.List -import Data.Bifunctor import Data.Maybe -import qualified Data.Tuple.Extra as Tup import qualified Control.Foldl as L import qualified Data.Set as S @@ -57,56 +56,4 @@ pairInPolys -> Bool pairInPolys polys (a,b) = any (pointInPolygon a) polys && any (pointInPolygon b) polys -shiftedGrid - :: Float -- ^ x min - -> Float -- ^ x max - -> Float -- ^ y min - -> Float -- ^ y max - -> [(Point2,Point2)] -shiftedGrid xmin xmax ymin ymax = grid - where - xd = xmax - xmin - yd = ymax - ymin - xsteps = ceiling $ (xd - 40) / 60 - ysteps = ceiling $ (yd - 40) / 60 - shift p = bimap (p +.+) (p +.+) - grid = map (shift (V2 (xmin + 20) (ymin+20))) $ makeGrid 60 xsteps 60 ysteps - --- creates a rectangular grid starting at (0,0) in the positive orthant --- needs fixing in degenerate (xstep or ystep == 0) cases -makeGrid - :: Float -- ^ horizontal step size - -> Int -- ^ number of horizontal steps - -> Float -- ^ vertical step size - -> Int -- ^ number of vertical steps - -> [(Point2,Point2)] -makeGrid x nx y ny - = nub - . concatMap doublePair - . concatMap (\p -> map (Tup.both (p +.+)) $ makeRect x y) - $ gridPoints x nx y ny - ---gridPoints :: Float -> Int -> Float -> Int -> [Point2] ---gridPoints x nx y ny = [V2 a b | a <- take nx $ scanl (+) 0 $ repeat x --- , b <- take ny $ scanl (+) 0 $ repeat y --- ] -gridPoints :: Float -> Int -> Float -> Int -> [Point2] -gridPoints x nx y ny = map f $ gridPoints' nx ny - where - f (a,b) = V2 (fromIntegral a * x) (fromIntegral b * y) - -gridPoints'' :: Float -> Int -> Float -> Int -> [(Point2,(Int,Int))] -gridPoints'' x nx y ny = map f $ gridPoints' nx ny - where - f (a,b) = (V2 (fromIntegral a * x) (fromIntegral b * y), (a,b)) - -gridPoints' :: Int -> Int -> [(Int,Int)] -gridPoints' nx ny = [(x,y) | x <- [0..nx-1], y <- [0..ny-1]] - -makeRect :: Float -> Float -> [(Point2,Point2)] -makeRect x y = map (bimap toV2 toV2) [((0,0),(x,0)) - ,((0,0),(0,y)) - ,((x,y),(x,0)) - ,((x,y),(0,y)) - ] diff --git a/src/Geometry/Polygon.hs b/src/Geometry/Polygon.hs index 4b7b02662..dff4b93d3 100644 --- a/src/Geometry/Polygon.hs +++ b/src/Geometry/Polygon.hs @@ -3,9 +3,10 @@ module Geometry.Polygon where import Geometry.Data import Geometry.LHS import Geometry.Vector +import ListHelp import Data.Maybe -import Data.List +--import Data.List import qualified Control.Foldl as L -- | Draw an anticlockwise rectangle based on maximal N E S W values. @@ -111,3 +112,11 @@ grahamEliminate xs = xs centroid :: Foldable t => t Point2 -> Point2 centroid = L.fold $ (/) <$> L.Fold (+.+) (V2 0 0) id <*> L.genericLength + +shrinkPolyOnEdges :: Float -> [Point2] -> [Point2] +shrinkPolyOnEdges x (p:q:ps) = map (shrinkVert x) . slideWindow 3 $ (p:q:ps) ++ [p,q] +shrinkPolyOnEdges _ _ = error "too few vertices in polygon" + +shrinkVert :: Float -> [Point2] -> Point2 +shrinkVert d (x:y:z:[]) = x +.+ (d *.* (normalizeV (x -.- y))) +.+ (d *.* (normalizeV (z -.- y))) +shrinkVert _ _ = error "wrong number of vertices" diff --git a/src/Grid.hs b/src/Grid.hs new file mode 100644 index 000000000..ad62e19b3 --- /dev/null +++ b/src/Grid.hs @@ -0,0 +1,78 @@ +module Grid where +import Geometry +import Bound + +--import Data.Function (on) +import Data.List +import Data.Bifunctor +--import Data.Maybe +import qualified Data.Tuple.Extra as Tup +import qualified Streaming.Prelude as S +--import qualified Control.Foldl as L +--import qualified Data.Set as S + +gridInPolygon :: Float -> [Point2] -> [Point2] +gridInPolygon gap ps = filter (flip pointInPolygon ps) + . maybe [] (boundedGrid gap) . boundPoints . S.each $ ps + +boundedGrid :: Float -> (Float,Float,Float,Float) -> [Point2] +boundedGrid gap (n,s,e,w) = gridPointsOff w s gap nx gap ny + where + nx = floor $ (e-w) / gap + ny = floor $ (n-s) / gap + +shiftedGrid + :: Float -- ^ x min + -> Float -- ^ x max + -> Float -- ^ y min + -> Float -- ^ y max + -> [(Point2,Point2)] +shiftedGrid xmin xmax ymin ymax = grid + where + xd = xmax - xmin + yd = ymax - ymin + xsteps = ceiling $ (xd - 40) / 60 + ysteps = ceiling $ (yd - 40) / 60 + shift p = bimap (p +.+) (p +.+) + grid = map (shift (V2 (xmin + 20) (ymin+20))) $ makeGrid 60 xsteps 60 ysteps + +-- creates a rectangular grid starting at (0,0) in the positive orthant +-- needs fixing in degenerate (xstep or ystep == 0) cases +makeGrid + :: Float -- ^ horizontal step size + -> Int -- ^ number of horizontal steps + -> Float -- ^ vertical step size + -> Int -- ^ number of vertical steps + -> [(Point2,Point2)] +makeGrid x nx y ny + = nub + . concatMap doublePair + . concatMap (\p -> map (Tup.both (p +.+)) $ makeRect x y) + $ gridPoints x nx y ny + +gridPointsOff :: Float -> Float -> Float -> Int -> Float -> Int -> [Point2] +gridPointsOff xoff yoff x nx y ny = map f $ gridPoints' nx ny + where + f (a,b) = V2 (xoff + fromIntegral a * x) (yoff + fromIntegral b * y) + +gridPoints :: Float -> Int -> Float -> Int -> [Point2] +gridPoints = gridPointsOff 0 0 +-- map f $ gridPoints' nx ny +-- where +-- f (a,b) = V2 (fromIntegral a * x) (fromIntegral b * y) + +gridPoints'' :: Float -> Int -> Float -> Int -> [(Point2,(Int,Int))] +gridPoints'' x nx y ny = map f $ gridPoints' nx ny + where + f (a,b) = (V2 (fromIntegral a * x) (fromIntegral b * y), (a,b)) + +gridPoints' :: Int -> Int -> [(Int,Int)] +gridPoints' nx ny = [(x,y) | x <- [0..nx-1], y <- [0..ny-1]] + +makeRect :: Float -> Float -> [(Point2,Point2)] +makeRect x y = map (bimap toV2 toV2) + [((0,0),(x,0)) + ,((0,0),(0,y)) + ,((x,y),(x,0)) + ,((x,y),(0,y)) + ] diff --git a/src/ListHelp.hs b/src/ListHelp.hs index 0ca28b196..03cff33b2 100644 --- a/src/ListHelp.hs +++ b/src/ListHelp.hs @@ -9,6 +9,7 @@ module ListHelp , errorHead , foldPairs , loopPairs + , slideWindow ) where import Data.List @@ -61,3 +62,6 @@ safeUncons _ = Nothing errorHead :: String -> [a] -> a errorHead _ (x:_) = x errorHead s [] = error s + +slideWindow :: Int -> [a] -> [[a]] +slideWindow n = foldr (zipWith (:)) (repeat []) . take n . tails