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/HUD.hs
+14 -14
View File
@@ -34,7 +34,7 @@ import qualified Data.Text as T
--import Data.Bifunctor
hudDrawings :: Universe -> Picture
hudDrawings uv = case _hudElement $ _hud w of
hudDrawings uv = case _hudElement $ _hud (_cWorld w) of
DisplayCarte -> drawCarte cfig w
DisplayInventory subinv -> drawInGameHUD uv
<> subInventoryDisplay subinv cfig w
@@ -59,7 +59,7 @@ inventoryDisplay cfig w = listPicturesAt 0 0 cfig invlist
inv = _crInv cr
invlist = concatMap (itemText' cr) (IM.toList inv)
++ displayFreeSlots
++ concatMap (closeObjectToTextPictures nfreeslots) (_closeObjects w)
++ concatMap (closeObjectToTextPictures nfreeslots) (_closeObjects (_cWorld w))
-- ++ map floorItemsColor (concatMap (closeObjectToTextPictures nfreeslots) (_closeObjects w))
-- floorItemsColor = case _hudElement (_hud w) of
-- DisplayInventory NoSubInventory -> id
@@ -131,7 +131,7 @@ subInventoryDisplay subinv cfig w = case subinv of
selcursor' ct = fromMaybe mempty $ ct 0 0 cfig curpos itcol (determineInvSelCursorWidth w) cury <$ it
selcursor = selcursor' selcursortype
selcursortype
| ButtonRight `M.member` _mouseButtons w = listCursorNESW
| ButtonRight `M.member` _mouseButtons (_cWorld w) = listCursorNESW
| otherwise = listCursorNSW
curpos = invSelPos w
cury = fromMaybe 1 $ augmentedInvSizes w IM.!? crSel (you w)
@@ -140,8 +140,8 @@ subInventoryDisplay subinv cfig w = case subinv of
_ -> mempty
equipcursors = IM.foldMapWithKey (f yellow) (_crInvEquipped cr)
f col invid epos = listTextPictureAt 144 0 cfig (selNumPos invid w) . color col $ text $ eqPosText epos
rboptions = if ButtonRight `M.member` _mouseButtons w
then drawRBOptions cfig w (_rbOptions w)
rboptions = if ButtonRight `M.member` _mouseButtons (_cWorld w)
then drawRBOptions cfig w (_rbOptions (_cWorld w))
else mempty
itmInfo :: Maybe Item -> [String]
@@ -151,7 +151,7 @@ itmInfo mit = fromMaybe [] $ do
displayTerminal :: Int -> Configuration -> World -> Picture
displayTerminal tid cfig w = fromMaybe mempty $ do
tm <- w ^? terminals . ix tid
tm <- w ^? cWorld . terminals . ix tid
return $ pictures
[ invHead cfig (_tmTitle tm ++ ":T" ++ show tid)
, renderListAt subInvX 60 cfig
@@ -187,7 +187,7 @@ drawRBOptions cfig w EquipOptions{_opEquip = es,_opSel=i, _opAllocateEquipment=a
where
midtext str = listTextPictureAt 252 0 cfig curpos (text str)
extratext str = listTextPictureAt 432 0 cfig curpos (text (str ++ deactivatetext))
deactivatetext = case w ^? rbOptions . opActivateEquipment . deactivateEquipment of
deactivatetext = case w ^? cWorld . rbOptions . opActivateEquipment . deactivateEquipment of
Just k -> " DEACTIVATES " ++ show (_iyBase $ _itType (_crInv (you w) IM.! k))
Nothing -> ""
curpos = invSelPos w
@@ -255,9 +255,9 @@ topCursorTypeWidth ctype width cfig w i
= ctype 0 0 cfig (selNumPos i w) (selNumCol i w) width (selNumSlots i w)
determineInvSelCursorWidth :: World -> Int
determineInvSelCursorWidth w = case _rbOptions w of
determineInvSelCursorWidth w = case _rbOptions (_cWorld w) of
NoRightButtonOptions -> topInvW
EquipOptions {} -> if ButtonRight `M.member` _mouseButtons w
EquipOptions {} -> if ButtonRight `M.member` _mouseButtons (_cWorld w)
then 47
else topInvW
@@ -309,9 +309,9 @@ drawCarte cfig w = pictures $
++ mapOverlay cfig w
++ [mainListCursor white iPos cfig]
where
iPos = _selLocation w
locs = map (\(_,s) -> (s,white)) . IM.elems . _seenLocations $ w
locPoss = map (cartePosToScreen cfig w . ($ w) . doWorldPos . fst) . IM.elems . _seenLocations $ w
iPos = _selLocation (_cWorld w)
locs = map (\(_,s) -> (s,white)) . IM.elems . _seenLocations $ (_cWorld w)
locPoss = map (cartePosToScreen cfig w . ($ w) . doWorldPos . fst) . IM.elems . _seenLocations $ (_cWorld w)
locTexts = map fst locs
displayListEndCoords :: Configuration -> [String] -> [Point2]
@@ -325,7 +325,7 @@ displayListEndCoords cfig ss = map (doWindowScale cfig) $ zipWith h ss $ map f [
mapOverlay :: Configuration -> World -> [Picture]
mapOverlay cfig w = (color (withAlpha 0.5 black) . polygon $ reverse $ rectNSWE 1 (-1) 1 (-1)) :
(mapMaybe (mapWall cfig w) . IM.elems $ _walls w)
(mapMaybe (mapWall cfig w) . IM.elems $ _walls (_cWorld w))
mapWall :: Configuration -> World -> Wall -> Maybe Picture
mapWall cfig w wl =
@@ -419,4 +419,4 @@ displayHP cid cfig w = translate (halfWidth cfig-80) (halfHeight cfig-20)
. leftPad 5 ' '
. show
. _crHP
$ _creatures w IM.! cid
$ _creatures (_cWorld w) IM.! cid
src/Dodge/Render/Lights.hs
+4 -4
View File
@@ -9,13 +9,13 @@ import Data.Maybe
import qualified IntMapHelp as IM
lightsToRender :: Configuration -> World -> [(Point3,Float,Point3)]
lightsToRender cfig w = mapMaybe getLS (IM.elems $ _lightSources w)
++ mapMaybe getTLS (_tempLightSources w)
lightsToRender cfig w = mapMaybe getLS (IM.elems $ _lightSources (_cWorld w))
++ mapMaybe getTLS (_tempLightSources (_cWorld w))
where
getLS = getlsparam . _lsParam
getTLS = getlsparam . _tlsParam
cbox = _boundBox w
cpos = _cameraCenter w
cbox = _boundBox (_cWorld w)
cpos = _cameraCenter (_cWorld w)
getlsparam ls
| not (pointInPolygon lpos cbox) && extraculltest = Nothing
| otherwise = Just ( _lsPos ls, rad^(2::Int) , _lsCol ls)
src/Dodge/Render/Picture.hs
+1 -1
View File
@@ -23,6 +23,6 @@ fixedCoordPictures u = case _menuLayers u of
customMouseCursor :: Configuration -> World -> Picture
customMouseCursor cfig w = winScale cfig
. uncurryV translate (_mousePos w)
. uncurryV translate (_mousePos (_cWorld w))
. color white
$ pictures [ line [V2 (-5) 0,V2 5 0] , line [V2 0 (-5),V2 0 5] ]
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
src/Dodge/Render/Walls.hs
+1 -1
View File
@@ -23,7 +23,7 @@ wallsToDraw w
<$> L.prefilter wlOpaqueDraw (L.premap f L.list)
<*> L.prefilter wlSeeThroughDraw (L.premap f L.list)
<*> L.premap getWallSPic L.mconcat
) (wlsFromIXs w $ zonesExtract (w ^. wlZoning) $ zoneOfSight' wlZoneSize w)
) (wlsFromIXs w $ zonesExtract (w ^. cWorld . wlZoning) $ zoneOfSight' wlZoneSize w)
--wallsToDraw
-- :: World
-- -> ( [((Point2,Point2),Point4)] ,[((Point2,Point2),Point4)], SPic )