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

Separate out concrete part of world

Browse Source
This commit is contained in:
justin
2022-07-25 12:10:50 +01:00
parent 3354d108be
commit b2efbd2b3e
134 changed files with 933 additions and 930 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Render/ShapePicture.hs
+44 -44
View File
@@ -78,7 +78,7 @@ worldSPic cfig w
<> singleSPic (anyTargeting cfig w)
where
foldup = foldMap'
filtOn f g = IM.filter (pointIsClose . f) (g w)
filtOn f g = IM.filter (pointIsClose . f) (g (_cWorld w))
pointIsClose = cullPoint cfig w
anyTargeting :: Configuration -> World -> SPic
@@ -128,30 +128,30 @@ shiftDraw' fpos fdir fdraw x = uncurryV translateSPf (fpos x)
cullPoint :: Configuration -> World -> Point2 -> Bool
cullPoint cfig w p
| debugOn Close_shape_culling cfig = pointInPolygon p (_boundBox w)
| otherwise = dist (_cameraCenter w) p < _viewDistance w
| debugOn Close_shape_culling cfig = pointInPolygon p (_boundBox (_cWorld w))
| otherwise = dist (_cameraCenter (_cWorld w)) p < _viewDistance (_cWorld w)
extraPics :: Configuration -> World -> Picture
extraPics cfig w = pictures (_decorations w)
<> concatMapPic drawTractorBeam (_tractorBeams w)
<> concatMapPic drawLinearShockwave (_linearShockwaves w)
<> concatMapPic drawShockwave (_shockwaves w)
<> concatMapPic drawLaser (_lasersToDraw w)
<> concatMapPic drawTeslaArc (_teslaArcs w)
extraPics cfig w = pictures (_decorations (_cWorld w))
<> concatMapPic drawTractorBeam (_tractorBeams (_cWorld w))
<> concatMapPic drawLinearShockwave (_linearShockwaves (_cWorld w))
<> concatMapPic drawShockwave (_shockwaves (_cWorld w))
<> concatMapPic drawLaser (_lasersToDraw (_cWorld w))
<> concatMapPic drawTeslaArc (_teslaArcs (_cWorld w))
-- <> concatMapPic drawParticle (_particles w)
<> concatMapPic drawRadarSweep (_radarSweeps w)
<> concatMapPic drawFlame (_flames w)
<> concatMapPic drawEnergyBall (_energyBalls w)
<> concatMapPic drawSpark (_sparks w)
<> concatMapPic drawBul (_bullets w)
<> concatMapPic drawBlip (_radarBlips w)
<> concatMapPic drawFlare (_flares w)
<> concatMapPic (dbArg (drawBeam . _bmDraw)) (_positronBeams $ _beams w)
<> concatMapPic (dbArg (drawBeam . _bmDraw)) (_electronBeams $ _beams w)
<> concatMapPic (dbArg (drawLightSource . _lsPict)) (_lightSources w)
<> concatMapPic drawRadarSweep (_radarSweeps (_cWorld w))
<> concatMapPic drawFlame (_flames (_cWorld w))
<> concatMapPic drawEnergyBall (_energyBalls (_cWorld w))
<> concatMapPic drawSpark (_sparks (_cWorld w))
<> concatMapPic drawBul (_bullets (_cWorld w))
<> concatMapPic drawBlip (_radarBlips (_cWorld w))
<> concatMapPic drawFlare (_flares (_cWorld w))
<> concatMapPic (dbArg (drawBeam . _bmDraw)) (_positronBeams $ _beams (_cWorld w))
<> concatMapPic (dbArg (drawBeam . _bmDraw)) (_electronBeams $ _beams (_cWorld w))
<> concatMapPic (dbArg (drawLightSource . _lsPict)) (_lightSources (_cWorld w))
<> testPic cfig w
<> concatMapPic clDraw (_clouds w )
<> concatMapPic ppDraw (_pressPlates w )
<> concatMapPic clDraw (_clouds (_cWorld w) )
<> concatMapPic ppDraw (_pressPlates (_cWorld w) )
<> viewClipBounds cfig w
<> debugDraw cfig w
@@ -196,7 +196,7 @@ debugDraw' cfig w bl = case bl of
rdraw pic = (mempty,pic)
drawCreatureDisplayTexts :: World -> Picture
drawCreatureDisplayTexts w = foldMap (creatureDisplayText w) (_creatures w)
drawCreatureDisplayTexts w = foldMap (creatureDisplayText w) (_creatures (_cWorld w))
drawPathBetween :: World -> Picture
drawPathBetween w = setLayer DebugLayer
@@ -207,22 +207,22 @@ drawPathBetween w = setLayer DebugLayer
where
nodepos = (`getNodePos` w)
nodelist = makePathBetween sp ep w
sp = _lSelect w
ep = _rSelect w
sp = _lSelect (_cWorld w)
ep = _rSelect (_cWorld w)
drawNodesNearSelect :: World -> Picture
drawNodesNearSelect w = setLayer DebugLayer
$ runIdentity (S.foldMap_ (drawZoneCol orange pnZoneSize) (zoneAroundPoint pnZoneSize sp))
<> color green (drawCross sp)
where
sp = _lSelect w
sp = _lSelect (_cWorld w)
drawInspectWalls :: World -> Picture
drawInspectWalls w = foldMap (drawInspectWall w)
$ filter (isJust . uncurry (intersectSegSeg a b) . _wlLine)
$ IM.elems $ _walls w
$ IM.elems $ _walls (_cWorld w)
where
(a,b) = _lLine w
(a,b) = _lLine (_cWorld w)
drawInspectWall :: World -> Wall -> Picture
drawInspectWall w wl = setLayer DebugLayer
@@ -233,7 +233,7 @@ drawInspectWall w wl = setLayer DebugLayer
drawDoorPaths :: World -> Int -> Picture
drawDoorPaths w drid = fromMaybe mempty $ do
paths <- w ^? doors . ix drid . drObstructs
paths <- w ^? cWorld . doors . ix drid . drObstructs
return $ foldMap (drawPathEdge . (^. _3)) paths
drawPathEdge :: PathEdge -> Picture
@@ -252,8 +252,8 @@ drawWorldSelect w = setLayer DebugLayer
$ color cyan (line [a,b])
<> color magenta (line [c,d])
where
(a,b) = _lLine w
(c,d) = _rLine w
(a,b) = _lLine (_cWorld w)
(c,d) = _rLine (_cWorld w)
drawFarWallDetect :: World -> Picture
drawFarWallDetect w = setLayer DebugLayer
@@ -264,7 +264,7 @@ drawFarWallDetect w = setLayer DebugLayer
] )
$ runIdentity $ S.toList_ $ streamViewpoints p w
where
p = _cameraViewFrom w
p = _cameraViewFrom (_cWorld w)
drawDDATest :: World -> Picture
drawDDATest w = runIdentity (S.foldMap_ (drawZoneCol orange 50) ps)
@@ -273,12 +273,12 @@ drawDDATest w = runIdentity (S.foldMap_ (drawZoneCol orange 50) ps)
<> color blue (runIdentity (S.foldMap_ drawCross qs'))
<> setLayer DebugLayer (color yellow (line [cvf,mwp]))
where
cvf = _cameraViewFrom w
cvf = _cameraViewFrom (_cWorld w)
mwp = mouseWorldPos w
ps = ddaStreamX 50 cvf mwp
ps' = ddaStreamY 50 (_cameraViewFrom w) (mouseWorldPos w)
qs = xIntercepts 50 (_cameraViewFrom w) (mouseWorldPos w)
qs' = yIntercepts 50 (_cameraViewFrom w) (mouseWorldPos w)
ps' = ddaStreamY 50 (_cameraViewFrom (_cWorld w)) (mouseWorldPos w)
qs = xIntercepts 50 (_cameraViewFrom (_cWorld w)) (mouseWorldPos w)
qs' = yIntercepts 50 (_cameraViewFrom (_cWorld w)) (mouseWorldPos w)
drawCross :: Point2 -> Picture
drawCross p = setLayer DebugLayer . color red . uncurryV translate p $ crossPic 5
@@ -299,7 +299,7 @@ drawWallSearchRays :: World -> Picture
drawWallSearchRays w = foldMap (f . fst) $ allVisibleWalls w
where
f p = setLayer DebugLayer $ color yellow $ uncurryV translate p (circle 5)
<> line [_cameraViewFrom w, p]
<> line [_cameraViewFrom (_cWorld w), p]
testPic :: Configuration -> World -> Picture
testPic _ _ = mempty
@@ -307,7 +307,7 @@ testPic _ _ = mempty
drawBoundingBox :: World -> Picture
drawBoundingBox w = setLayer DebugLayer $ color green $ line $ (x:xs) ++ [x]
where
(x:xs) = _boundBox w
(x:xs) = _boundBox (_cWorld w)
clDraw :: Cloud -> Picture
clDraw c = translate3 (_clPos c) (drawCloud (_clPict c) c)
@@ -329,7 +329,7 @@ soundPic cfig w s = fixedSizePicClampArrow 50 50 thePic p cfig w
where
p = _soundPos s
thePic
= rotate (_cameraRot w)
= rotate (_cameraRot (_cWorld w))
. scale theScale theScale
. centerText
. soundToOnomato
@@ -348,7 +348,7 @@ drawMousePosition cfig w = setLayer FixedCoordLayer . winScale cfig
mwp = mouseWorldPos w
drawWlIDs :: Configuration -> World -> Picture
drawWlIDs cfig w = setLayer FixedCoordLayer $ foldMap f (_walls w)
drawWlIDs cfig w = setLayer FixedCoordLayer $ foldMap f (_walls (_cWorld w))
where
f wl
| dist (_crPos $ you w) (fst (_wlLine wl)) > 200 = mempty -- this should be improved with a better "on screen test"
@@ -374,7 +374,7 @@ drawPathing cfig w = setLayer DebugLayer
<> foldMap dispInc (graphToIncidence gr)
where
dispInc (p,n) = setDepth 2 . uncurryV translate p . scale 0.1 0.1 $ text $ show n
gr = _pathGraph w
gr = _pathGraph (_cWorld w)
crDisplayInfo :: Configuration -> World -> Creature -> Maybe (Point2,[String])
crDisplayInfo cfig w cr
@@ -401,7 +401,7 @@ fpreShow str = fmap (((rightPad 7 '.'str ++ "...") ++) . show)
drawCrInfo :: Configuration -> World -> Picture
drawCrInfo cfig w = setLayer FixedCoordLayer
$ renderInfoListsAt (2*hw - 400) 0 cfig w
$ mapMaybe (crDisplayInfo cfig w) $ IM.elems $ _creatures w
$ mapMaybe (crDisplayInfo cfig w) $ IM.elems $ _creatures (_cWorld w)
where
hw = halfWidth cfig
@@ -410,14 +410,14 @@ viewBoundaries w = setLayer DebugLayer $ color green (foldMap (polygonWire . _gr
<> color yellow (foldMap (\q -> line [p,q]) $ farWallPoints p w)
where
p = _crPos $ you w
grs = filter (pointInOrOnPolygon p . _grBound) (_gameRooms w)
grs = filter (pointInOrOnPolygon p . _grBound) (_gameRooms (_cWorld w))
viewClipBounds :: Configuration -> World -> Picture
viewClipBounds cfig w
| _debug_view_clip_bounds cfig == AllRoomClipBoundaries
= setLayer DebugLayer $ color green $ foldMap (polygonWire . _cpPoints) (_roomClipping w)
= setLayer DebugLayer $ color green $ foldMap (polygonWire . _cpPoints) (_roomClipping (_cWorld w))
| _debug_view_clip_bounds cfig == IntersectingRoomClipBoundaries
= setLayer DebugLayer $ f (_roomClipping w)
= setLayer DebugLayer $ f (_roomClipping (_cWorld w))
| otherwise = mempty
where
f (x:xs) = g x xs <> f xs