Use grid when creating block debris

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_ ((,,,) 

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)

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

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

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 = []

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

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 

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]

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))
-               ]
 

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"

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))
+    ]

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