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

Fix wall zoning

Browse Source
This commit is contained in:
justin
2022-06-27 09:56:54 +01:00
parent 7778fb0403
commit 90af97ee22
15 changed files with 128 additions and 34 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Config/Data.hs
+3
View File
@@ -41,6 +41,9 @@ data DebugBool
| Bound_box_screen
| Show_wall_search_rays
| Show_dda_test
| Show_far_wall_detect
| Show_select
| Inspect_wall
deriving (Generic, Eq,Ord,Bounded, Enum, Show)
data ResFactor = FullRes | HalfRes | QuarterRes
deriving (Generic, Show, Eq, Ord, Enum, Bounded)
src/Dodge/Data.hs
+2 -1
View File
@@ -169,9 +169,9 @@ data World = World
, _genRooms :: IM.IntMap Room
, _deathDelay :: Maybe Int
, _testFloat :: Float
, _wSelect :: (Point2,Point2)
}
newtype GenParams = GenParams
{ _sensorCoding :: M.Map DamageType (PaletteColor,DecorationShape)
}
@@ -1405,6 +1405,7 @@ data PSType = PutCrit {_unPutCrit :: Creature}
| PutDoor Color (World -> Bool) [(Point2,Point2)]
| RandPS (State StdGen PSType)
| PutShape Shape
| PutForeground ForegroundShape
| PutWorldUpdate (PlacementSpot -> World -> World)
| PutNothing
| PutUsingGenParams (World -> (World,PSType))
src/Dodge/Data/ForegroundShape.hs
+1 -1
View File
@@ -9,7 +9,7 @@ data ForegroundShape = ForegroundShape
{ _fsID :: Int
, _fsPos :: Point2
, _fsDir :: Float
, _fsRad :: Float
, _fsRad :: Float -- This should probably be a bounding box
, _fsSPic :: SPic
}
deriving (Eq,Show,Ord)
src/Dodge/Default/World.hs
+1
View File
@@ -110,6 +110,7 @@ defaultWorld = World
, _testFloat = 0
, _boundBox = square 100
, _boundDist = (100,-100,100,-100)
, _wSelect = (0,0)
}
youLight :: TempLightSource
youLight = TLS
src/Dodge/Floor.hs
+4 -4
View File
@@ -41,10 +41,10 @@ initialAnoTree :: Annotation
initialAnoTree = OnwardList
$ intersperse (AnTree corDoor)
[ IntAnno $ AnTree . startRoom
, AnRoom slowDoorRoom
, AnRoom $ roomCCrits 10
, AnTree firstBreather
, AnTree $ telRoomLev 1 >>= rToOnward "telRoomLev" . pure . cleatOnward
-- , AnRoom slowDoorRoom
-- , AnRoom $ roomCCrits 10
-- , AnTree firstBreather
-- , AnTree $ telRoomLev 1 >>= rToOnward "telRoomLev" . pure . cleatOnward
]
extraAnoList :: [Annotation]
src/Dodge/Initialisation.hs
+1 -1
View File
@@ -41,6 +41,6 @@ initialWorld = defaultWorld
}
testStringInit :: Configuration -> World -> [String]
testStringInit _ _ = mempty
testStringInit _ w = [show $ _boundDist w]
--testStringInit = map (show . _drStatus) . IM.elems . _doors
--testStringInit = const . const []
src/Dodge/Placement/PlaceSpot.hs
+4
View File
@@ -96,6 +96,7 @@ placeSpotID ps pt w = case pt of
PutTerminal tm -> plNewUpID terminals tmID tm w
PutFlIt itm -> plNewUpID floorItems flItID (createFlIt p rot itm) w
PutCrit cr -> plNewUpID creatures crID (mvCr p rot cr) w
PutForeground fs -> plNewUpID shapes fsID (mvFS p rot fs) w
PutMachine pps mc -> plMachine (map doShift pps) mc p rot w
PutLS ls -> plNewUpID lightSources lsID (mvLS p' rot ls) w
PutPPlate pp -> plNewUpID pressPlates ppID (mvPP p rot pp) w
@@ -172,6 +173,9 @@ mvPP p rot pp = pp {_ppPos = p,_ppRot = rot}
mvCr :: Point2 -> Float -> Creature -> Creature
mvCr p rot cr = cr {_crPos = p,_crOldPos = p,_crDir = rot}
mvFS :: Point2 -> Float -> ForegroundShape -> ForegroundShape
mvFS p a = (fsDir +~ a) . (fsPos %~ ( (p +.+) . rotateV a ))
plMachine :: [Point2] -> Machine -> Point2 -> Float -> World -> (Int,World)
plMachine wallpoly mc p rot gw = (mcid
, gw & machines %~ addMc
src/Dodge/Render/ShapePicture.hs
+44 -9
View File
@@ -7,6 +7,7 @@ import Dodge.Render.InfoBox
import Dodge.Debug.Picture
import Dodge.Picture.SizeInvariant
import Dodge.Data
import Dodge.Zone
import Dodge.Base
--import Dodge.Base.Window
import Dodge.SoundLogic.LoadSound
@@ -14,6 +15,7 @@ import Dodge.Graph
import Dodge.GameRoom
import Dodge.Update.Camera
import Dodge.Item.Draw
import Dodge.Wall.Zone
--import Dodge.Zone
import Geometry
import Geometry.Zone
@@ -34,9 +36,11 @@ import qualified Streaming.Prelude as S
worldSPic :: Configuration -> World -> SPic
worldSPic cfig w =
(extraShapes w, extraPics cfig w)
--(mempty, extraPics cfig w)
<> foldMap (dbArg _prDraw) (filtOn _prPos _props)
<> foldMap (shiftDraw _blPos _blDir _blDraw) (filtOn _blPos _blocks)
<> foldMap (shiftDraw _fsPos _fsDir (const _fsSPic)) (filtOn _fsPos _shapes)
-- <> foldMap (\fs -> uncurryV translateSPf (_fsPos fs) . rotateSP (_fsDir fs) $ _fsSPic fs) (_shapes w)
<> foldMap (dbArg _cpPict) (filtOn _cpPos _corpses)
<> foldMap ((($ w) . ($ cfig)) . dbArg _crPict) (filtOn _crPos _creatures)
<> foldMap floorItemSPic (filtOn _flItPos _floorItems)
@@ -51,7 +55,6 @@ 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)
@@ -72,20 +75,55 @@ extraPics cfig w = pictures (_decorations w)
<> concatMapPic clDraw (_clouds w )
<> concatMapPic ppDraw (_pressPlates w )
<> soundPics cfig w
<> viewBoundaries cfig w
<> viewClipBounds cfig w
<> drawMousePosition cfig w
<> drawWallIDs cfig w
<> drawPathing cfig w
<> drawCrInfo cfig w
<> cfigdraw View_boundaries (const viewBoundaries)
<> cfigdraw Show_bound_box (const drawBoundingBox)
<> cfigdraw Show_wall_search_rays (const drawWallSearchRays)
<> cfigdraw Show_dda_test (const drawDDATest)
<> cfigdraw Show_far_wall_detect (const drawFarWallDetect)
<> cfigdraw Show_select (const drawWorldSelect)
<> cfigdraw Inspect_wall (const drawInspectWalls)
where
cfigdraw boption draw
| debugOn boption cfig = draw cfig w
| otherwise = mempty
drawInspectWalls :: World -> Picture
drawInspectWalls w = foldMap (drawInspectWall w)
$ filter (isJust . uncurry (intersectSegSeg a b) . _wlLine)
$ IM.elems $ _walls w
where
(a,b) = _wSelect w
drawInspectWall :: World -> Wall -> Picture
drawInspectWall _ wl = setLayer DebugLayer $
color rose (thickLine 3 [a,b])
<> foldMap (drawZone zoneSize)
(runIdentity $ S.toList_ $ zoneOfWall wl)
where
(a,b) = _wlLine wl
-- $ line [a,b]
-- where
-- (a,b) = _wSelect w
drawWorldSelect :: World -> Picture
drawWorldSelect w = setLayer DebugLayer . color cyan
$ line [a,b]
where
(a,b) = _wSelect w
drawFarWallDetect :: World -> Picture
drawFarWallDetect w = setLayer DebugLayer . color yellow
. concatMap (\q -> line [p,q])
. map (\q -> fst $ collidePoint p q $ S.filter wlIsOpaque $ wallsAlongLine p q w)
$ runIdentity $ S.toList_ $ streamViewpoints p w
where
p = _cameraViewFrom w
drawDDATest :: World -> Picture
drawDDATest w = runIdentity (S.foldMap_ (drawZone 50) ps)
<> runIdentity (S.foldMap_ (drawZone' 50) ps')
@@ -107,7 +145,7 @@ crossPic :: Float -> Picture
crossPic x = line [V2 x x,V2 (-x) (-x)] <> line [V2 (-x) x,V2 x (-x)]
drawZone :: Float -> V2 Int -> Picture
drawZone s (V2 x y) = setLayer DebugLayer . color orange $ line (p:ps ++ [p])
drawZone s (V2 x y) = setLayer DebugLayer . color orange $ thickLine 2 (p:ps ++ [p])
where
(p:ps) = zipWith (+.+) innerSquare $ map ((s*.*) . (each %~ fromIntegral)) [V2 x y, V2 (x+1) y, V2 (x+1) (y+1), V2 x (y+1)]
@@ -235,12 +273,9 @@ drawCrInfo cfig w
where
hw = halfWidth cfig
viewBoundaries :: Configuration -> World -> Picture
viewBoundaries cfig w
| debugOn View_boundaries cfig
= setLayer DebugLayer $ color green (concatMap (polygonWire . _grBound) grs)
<> color yellow (concatMap (\q -> line [p,q]) $ farWallPoints p w)
| otherwise = []
viewBoundaries :: World -> Picture
viewBoundaries w = setLayer DebugLayer $ color green (concatMap (polygonWire . _grBound) grs)
<> color yellow (concatMap (\q -> line [p,q]) $ farWallPoints p w)
where
p = _crPos $ you w
grs = filter (pointInOrOnPolygon p . _grBound) (_gameRooms w)
src/Dodge/Room/Foreground.hs
+23
View File
@@ -5,8 +5,12 @@ import Geometry
import Shape
import Quaternion
import Dodge.Data.ForegroundShape
import Dodge.Default.Foreground
import Data.List
import Data.Maybe
import Control.Lens
import ShapePicture
highDiagonalMesh
:: Point2
@@ -111,6 +115,25 @@ girderVCapLR csize h d w x y = thinHighBar h (x -.- n) (x +.+ n)
where
n = csize *.* vNormal (normalizeV (x -.- y))
girderV'
:: Float -- ^ "cap" size
-> Float -- ^ height
-> Float -- ^ distance between cross bars
-> Float -- ^ width
-> Point2 -> Point2 -> ForegroundShape
girderV' csize h d w x y = defaultForeground
& fsPos .~ m
& fsRad .~ dist m x'
& fsSPic .~ noPic sh
where
m = midPoint x y
x' = x - m
y' = y - m
sh = thinHighBar h (x' -.- n) (x' +.+ n)
<> thinHighBar h (y' -.- n) (y' +.+ n)
<> girderV h d w x' y'
n = csize *.* vNormal (normalizeV (x' -.- y'))
girderV
:: Float -- ^ height
-> Float -- ^ distance between cross bars
src/Dodge/Room/Modify/Girder.hs
+4 -4
View File
@@ -151,13 +151,13 @@ addGirderLights rm = do
midw = wiToFloat rm midi
extragirderpos = nub $ map (\(wi,hi) -> (wi - midi, hi)) lpis
extragirders = mapMaybe (\(i,hi) -> case i of
x | x < 0 -> Just $ girderVCapL 20 96 20 10 (V2 (midw - 10) (hiToFloat rm hi))
x | x < 0 -> Just $ girderV' 20 96 20 10 (V2 (midw - 10) (hiToFloat rm hi))
(V2 0 (hiToFloat rm hi))
x | x > 0 -> Just $ girderVCapL 20 96 20 10 (V2 (midw + 10) (hiToFloat rm hi))
x | x > 0 -> Just $ girderV' 20 96 20 10 (V2 (midw + 10) (hiToFloat rm hi))
(V2 w (hiToFloat rm hi))
_ -> Nothing
) extragirderpos
return $ rm & rmPmnts .++~
(sps0 (PutShape $ colorSH black $ girderVCapLR 20 96 20 10 (V2 midw 0) (V2 midw h))
(sps0 (PutForeground $ girderV' 20 96 20 10 (V2 midw 0) (V2 midw h))
: map (\p -> sps (PS p 0) (PutLS $ lsColPos 0.75 (V3 0 0 90))) lps
) ++ map (sps0 . PutShape . colorSH black) extragirders
) ++ map (sps0 . PutForeground) extragirders
src/Dodge/Update.hs
+7
View File
@@ -35,6 +35,7 @@ import Control.Applicative
--import Data.Monoid
--import System.Random
import qualified Streaming.Prelude as S
import SDL
--import Streaming
{- For most menus the only way to change the world is using event handling. -}
@@ -57,6 +58,7 @@ functionalUpdate cfig w = checkEndGame
-- . updateRandGen
. (mouseButtons . each .~ True) -- to determine if the mouse button is held
. (worldClock +~ 1)
. updateWorldSelect
. doRewind
. (doubleMouseHammer %~ moveHammerUp)
. updateDistortions
@@ -100,6 +102,11 @@ functionalUpdate cfig w = checkEndGame
where
(x,y) = cloudZoneOfPoint $ stripZ $ _clPos cl
updateWorldSelect :: World -> World
updateWorldSelect w = case w ^? mouseButtons . ix ButtonLeft of
Nothing -> w
Just False -> w & wSelect . _1 .~ mouseWorldPos w
Just True -> w & wSelect . _2 .~ mouseWorldPos w
mcChooseUpdate :: Machine -> Machine -> World -> World
mcChooseUpdate mc mc'
src/Dodge/Update/Camera.hs
+1 -1
View File
@@ -4,7 +4,7 @@ and the position that the character sees from: '_cameraViewFrom'. -}
module Dodge.Update.Camera
( updateCamera
, farWallPoints
-- , streamViewpoints
, streamViewpoints
, farWallDistDirection
) where
import Dodge.Data
src/Dodge/Wall/Zone.hs
+16 -9
View File
@@ -6,19 +6,26 @@ import Dodge.Zone
import Dodge.Base
import Control.Lens
import Data.Foldable
--import Data.Foldable
import Streaming
import qualified Streaming.Prelude as S
zoneOfWall :: Wall -> [(Int,Int)]
zoneOfWall wl
| uncurry dist wlline <= 2*zoneSize = [zoneOfPoint $ uncurry midPoint wlline ]
| otherwise = map zoneOfPoint $ uncurry (divideLine zoneSize) wlline
where
wlline = _wlLine wl
zoneOfWall :: Wall -> Stream (Of (V2 Int)) Identity ()
zoneOfWall = uncurry zoneOfLineStream . _wlLine
-- | uncurry dist wlline <= 2*zoneSize = [zoneOfPoint $ uncurry midPoint wlline ]
-- | otherwise = map zoneOfPoint $ uncurry (divideLine zoneSize) wlline
-- where
-- wlline = _wlLine wl
insertWallInZones :: Wall -> World -> World
insertWallInZones wl = wallsZone . znObjects
%~ flip (foldl' (flip $ \(a,b) -> insertIMInZone a b (_wlID wl) wl)) (zoneOfWall wl)
%~ (runIdentity . (\wlzns -> S.fold_ doinsert wlzns id (zoneOfWall wl)))
where
doinsert wlzns (V2 x y) = insertIMInZone x y (_wlID wl) wl wlzns
deleteWallFromZones :: Wall -> World -> World
deleteWallFromZones wl = wallsZone . znObjects
%~ flip (foldl' (flip $ \(a,b) -> deleteIMInZone a b (_wlID wl))) (zoneOfWall wl)
%~ (runIdentity . (\wlzns -> S.fold_ dodelete wlzns id (zoneOfWall wl)))
where
dodelete wlzns (V2 x y) = deleteIMInZone x y (_wlID wl) wlzns
-- %~ flip (foldl' (flip $ \(a,b) -> deleteIMInZone a b (_wlID wl))) (zoneOfWall wl)
src/Dodge/Zone.hs
+2
View File
@@ -13,6 +13,7 @@ module Dodge.Zone
, zoneAroundPoint
, floorHun
, zoneOfLine
, zoneOfLineStream
, wallsDoubleScreen
, cloudZoneOfPoint
, cloudsNearPoint
@@ -86,6 +87,7 @@ zoneOfLine (V2 aa ab) (V2 ba bb)
--f (x,y) = [(p,r) | p <-[x-2..x+2] , r<-[y-2..y+2]]
zoneOfLineStream :: Point2 -> Point2 -> Stream (Of (V2 Int)) Identity ()
--zoneOfLineStream = ddaSqStream zoneSize
zoneOfLineStream = ddaStream zoneSize
zoneOfLineIntMap :: Point2 -> Point2 -> IM.IntMap IS.IntSet
src/Geometry/Zone.hs
+15 -4
View File
@@ -3,7 +3,7 @@ module Geometry.Zone
( ddaExt
, ddaExt'
, ddaSq
-- , ddaSqStream
, ddaSqStream
, ddaStream
, ddaStreamX
, ddaStreamY
@@ -144,6 +144,17 @@ ddaExt' s sp@(V2 sx sy) ep@(V2 ex ey)
[y1 .. y2]
| otherwise = zip (map (divTo s) [y2x,y2x+xdy..])
[y2-1 .. y1-1]
ddaSqStream :: Float -> Point2 -> Point2 -> Stream (Of (V2 Int)) Identity ()
ddaSqStream s sp ep = S.each [V2 x y | x <- makeInterval sx ex, y <- makeInterval sy ey]
where
V2 sx sy = sizeZoneOfPoint' s sp
V2 ex ey = sizeZoneOfPoint' s ep
makeInterval :: Int -> Int -> [Int]
makeInterval x y
| x < y = [x-1..y+1]
| otherwise = [y-1..x+1]
ddaStream :: Float -> Point2 -> Point2 -> Stream (Of (V2 Int)) Identity ()
ddaStream s sp ep = S.map (sizeZoneOfPoint' s)
$ S.yield sp
@@ -160,11 +171,11 @@ xIntercepts :: Float -> Point2 -> Point2 -> Stream (Of Point2) Identity ()
{-# INLINE xIntercepts #-}
xIntercepts s (V2 sx sy) (V2 ex ey)
| xdx == 0 = mempty
| xdx > 0 = S.each $ zipWith V2 [sx',sx'+xdx*50..ex] [sy',sy'+ydx*50..ey]
| otherwise = S.each $ zipWith V2 [sx'-50,sx'+xdx*50-50..ex-50] [sy',sy'+ydx*50..ey]
| xdx > 0 = S.each $ zipWith V2 [sx',sx'+xdx*50..ex] ([sy',sy'+ydx*50..ey] ++ repeat ey)
| otherwise = S.each $ zipWith V2 [sx'-50,sx'+xdx*50-50..ex-50] ([sy',sy'+ydx*50..ey] ++ repeat ey)
where
xdx = signum (ex - sx)
ydx = (ey - sy) / abs (ex - sx)
ydx = (ey - sy) / abs (ex - sx) -- carefull: if this is zero
sy' = sy + ydx * abs (sx - sx')
sx' | xdx < 0 = sx - modTo s sx