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

Use grid when creating block debris

Browse Source
This commit is contained in:
justin
2022-07-13 10:44:18 +01:00
parent 1ccb87ff13
commit 6c50021f04
12 changed files with 139 additions and 65 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Bound.hs
+1
View File
@@ -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 -2
View File
@@ -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
+41 -1
View File
@@ -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
-1
View File
@@ -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
-2
View File
@@ -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
+1
View File
@@ -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
-1
View File
@@ -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
+1 -3
View File
@@ -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
+1 -54
View File
@@ -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
+10 -1
View File
@@ -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
+78
View File
@@ -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
+4
View File
@@ -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