Tweak turrets
This commit is contained in:
+288
-249
@@ -1,113 +1,118 @@
|
||||
module Dodge.Render.ShapePicture
|
||||
( worldSPic
|
||||
) where
|
||||
import Dodge.Block.Draw
|
||||
import Dodge.Machine.Draw
|
||||
import Dodge.LinearShockwave.Draw
|
||||
import Dodge.Prop.Draw
|
||||
import Dodge.TractorBeam.Draw
|
||||
import Dodge.Shockwave.Draw
|
||||
import Dodge.Tesla.Arc.Draw
|
||||
import Dodge.Laser.Draw
|
||||
import Dodge.Cloud.Draw
|
||||
import Dodge.Zoning
|
||||
import Dodge.Button.Draw
|
||||
import Dodge.LightSource.Draw
|
||||
import Dodge.Targeting.Draw
|
||||
import Dodge.Beam.Draw
|
||||
import Dodge.RadarSweep.Draw
|
||||
import Dodge.Projectile.Draw
|
||||
import Dodge.Item.Draw.SPic
|
||||
import Dodge.EnergyBall.Draw
|
||||
import Dodge.Creature.Picture.Awareness
|
||||
import Dodge.Creature.Picture
|
||||
import Dodge.Flame.Draw
|
||||
import Dodge.Bullet.Draw
|
||||
import Dodge.Spark.Draw
|
||||
import Dodge.RadarBlip
|
||||
import Dodge.Flare
|
||||
import Dodge.ShortShow
|
||||
import Dodge.Data.Config
|
||||
import Dodge.Render.InfoBox
|
||||
import Dodge.Debug.Picture
|
||||
import Dodge.Picture.SizeInvariant
|
||||
import Dodge.Zone
|
||||
import Dodge.Data.World
|
||||
import Dodge.Base
|
||||
import Dodge.SoundLogic.LoadSound
|
||||
import Dodge.Graph
|
||||
import Dodge.GameRoom
|
||||
import Dodge.Update.Camera
|
||||
import Dodge.Render.List
|
||||
import Dodge.Path
|
||||
import Geometry
|
||||
import Geometry.Zone
|
||||
import ShapePicture
|
||||
import Picture
|
||||
import Sound.Data
|
||||
import Geometry.ConvexPoly
|
||||
import ShortShow
|
||||
import Polyhedra
|
||||
module Dodge.Render.ShapePicture (
|
||||
worldSPic,
|
||||
) where
|
||||
|
||||
import StreamingHelp
|
||||
import qualified IntMapHelp as IM -- Lazy?
|
||||
import qualified Data.Map.Strict as M
|
||||
import Control.Lens
|
||||
import Data.Maybe
|
||||
import qualified Streaming.Prelude as S
|
||||
import qualified Data.Graph.Inductive as FGL
|
||||
import qualified Data.Set as Set
|
||||
import Padding
|
||||
import Data.Foldable
|
||||
import qualified Data.Graph.Inductive as FGL
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.Maybe
|
||||
import qualified Data.Set as Set
|
||||
import Dodge.Base
|
||||
import Dodge.Beam.Draw
|
||||
import Dodge.Block.Draw
|
||||
import Dodge.Bullet.Draw
|
||||
import Dodge.Button.Draw
|
||||
import Dodge.Cloud.Draw
|
||||
import Dodge.Creature.Picture
|
||||
import Dodge.Creature.Picture.Awareness
|
||||
import Dodge.Data.Config
|
||||
import Dodge.Data.World
|
||||
import Dodge.Debug.Picture
|
||||
import Dodge.EnergyBall.Draw
|
||||
import Dodge.Flame.Draw
|
||||
import Dodge.Flare
|
||||
import Dodge.GameRoom
|
||||
import Dodge.Graph
|
||||
import Dodge.Item.Draw.SPic
|
||||
import Dodge.Laser.Draw
|
||||
import Dodge.LightSource.Draw
|
||||
import Dodge.LinearShockwave.Draw
|
||||
import Dodge.Machine.Draw
|
||||
import Dodge.Path
|
||||
import Dodge.Picture.SizeInvariant
|
||||
import Dodge.Projectile.Draw
|
||||
import Dodge.Prop.Draw
|
||||
import Dodge.RadarBlip
|
||||
import Dodge.RadarSweep.Draw
|
||||
import Dodge.Render.InfoBox
|
||||
import Dodge.Render.List
|
||||
import Dodge.Shockwave.Draw
|
||||
import Dodge.ShortShow
|
||||
import Dodge.SoundLogic.LoadSound
|
||||
import Dodge.Spark.Draw
|
||||
import Dodge.Targeting.Draw
|
||||
import Dodge.Tesla.Arc.Draw
|
||||
import Dodge.TractorBeam.Draw
|
||||
import Dodge.Update.Camera
|
||||
import Dodge.Zone
|
||||
import Dodge.Zoning
|
||||
import Geometry
|
||||
import Geometry.ConvexPoly
|
||||
import Geometry.Zone
|
||||
import qualified IntMapHelp as IM
|
||||
import Padding
|
||||
import Picture
|
||||
import Polyhedra
|
||||
import ShapePicture
|
||||
import ShortShow
|
||||
import Sound.Data
|
||||
import qualified Streaming.Prelude as S
|
||||
|
||||
singleSPic :: SPic -> SPic
|
||||
singleSPic = id
|
||||
|
||||
worldSPic :: Configuration -> World -> SPic
|
||||
worldSPic cfig w
|
||||
= singleSPic (mempty, extraPics cfig w)
|
||||
<> foldup drawProp' (filtOn _prPos _props)
|
||||
<> foldup drawProjectile (filtOn _prjPos _projectiles)
|
||||
<> foldup (shiftDraw _blPos _blDir (drawBlock . _blDraw)) (filtOn _blPos _blocks)
|
||||
<> foldup (shiftDraw _fsPos _fsDir (const _fsSPic)) (filtOn _fsPos _foregroundShapes)
|
||||
<> foldup (shiftDraw' _cpPos _cpDir _cpSPic) (filtOn _cpPos _corpses)
|
||||
<> foldup drawCreature (filtOn _crPos _creatures)
|
||||
<> foldup floorItemSPic (filtOn _flItPos _floorItems)
|
||||
<> foldup btSPic (filtOn _btPos _buttons)
|
||||
<> foldup mcSPic (filtOn _mcPos _machines)
|
||||
<> singleSPic (anyTargeting cfig w)
|
||||
worldSPic cfig w =
|
||||
singleSPic (mempty, extraPics cfig w)
|
||||
<> foldup drawProp' (filtOn _prPos _props)
|
||||
<> foldup drawProjectile (filtOn _prjPos _projectiles)
|
||||
<> foldup (shiftDraw _blPos _blDir (drawBlock . _blDraw)) (filtOn _blPos _blocks)
|
||||
<> foldup (shiftDraw _fsPos _fsDir (const _fsSPic)) (filtOn _fsPos _foregroundShapes)
|
||||
<> foldup (shiftDraw' _cpPos _cpDir _cpSPic) (filtOn _cpPos _corpses)
|
||||
<> foldup drawCreature (filtOn _crPos _creatures)
|
||||
<> foldup floorItemSPic (filtOn _flItPos _floorItems)
|
||||
<> foldup btSPic (filtOn _btPos _buttons)
|
||||
<> foldup mcSPic (filtOn _mcPos _machines)
|
||||
<> singleSPic (anyTargeting cfig w)
|
||||
where
|
||||
foldup = foldMap'
|
||||
filtOn f g = IM.filter (pointIsClose . f) (g (_cWorld w))
|
||||
pointIsClose = cullPoint cfig w
|
||||
|
||||
anyTargeting :: Configuration -> World -> SPic
|
||||
anyTargeting cfig w = (mempty,pictures $ IM.elems $ IM.mapMaybe f $ _crInv cr)
|
||||
anyTargeting cfig w = (mempty, pictures $ IM.elems $ IM.mapMaybe f $ _crInv cr)
|
||||
where
|
||||
cr = you w
|
||||
f it = fmap (\g -> drawTargeting g it cr cfig w) (it ^? itTargeting . tgDraw)
|
||||
|
||||
drawCreature :: Creature -> SPic
|
||||
drawCreature cr = case _crType cr of
|
||||
Humanoid {} -> basicCrPict cr
|
||||
Barreloid {} -> picAtCrPos1 (setDepth 20 $ pictures
|
||||
[ color orange $ circleSolid 10
|
||||
, setDepth 0.049 . color (greyN 0.5) $ circleSolid 8
|
||||
, color (greyN 0.5) $ circleSolid 8
|
||||
]) cr
|
||||
Lampoid{_lampHeight=h} -> picAtCrPosNoRot1 (lampCrPic h) cr
|
||||
Turretoid -> mempty
|
||||
Humanoid{} -> basicCrPict cr
|
||||
Barreloid{} ->
|
||||
picAtCrPos1
|
||||
( setDepth 20 $
|
||||
pictures
|
||||
[ color orange $ circleSolid 10
|
||||
, setDepth 0.049 . color (greyN 0.5) $ circleSolid 8
|
||||
, color (greyN 0.5) $ circleSolid 8
|
||||
]
|
||||
)
|
||||
cr
|
||||
Lampoid{_lampHeight = h} -> picAtCrPosNoRot1 (lampCrPic h) cr
|
||||
NonDrawnCreature -> mempty
|
||||
|
||||
lampCrPic :: Float -> Picture
|
||||
lampCrPic h = pictures
|
||||
[ setLayer BloomLayer (setDepth h . color white $ circleSolid 3)
|
||||
, foldMap (polyToTris . map f) $ boxXYZnobase 5 5 (h-1)
|
||||
]
|
||||
lampCrPic h =
|
||||
pictures
|
||||
[ setLayer BloomLayer (setDepth h . color white $ circleSolid 3)
|
||||
, foldMap (polyToTris . map f) $ boxXYZnobase 5 5 (h -1)
|
||||
]
|
||||
where
|
||||
f pos = Verx (pos -.-.- V3 2.5 2.5 0) blue [] BottomLayer polyNum
|
||||
--DrawnCreature f -> f cr
|
||||
--
|
||||
|
||||
--DrawnCreature f -> f cr
|
||||
--
|
||||
picAtCrPosNoRot1 :: Picture -> Creature -> SPic
|
||||
--{-# INLINE picAtCrPos #-}
|
||||
picAtCrPosNoRot1 thePic cr = (,) mempty $ uncurryV translate (_crPos cr) thePic
|
||||
@@ -117,93 +122,96 @@ picAtCrPos1 :: Picture -> Creature -> SPic
|
||||
picAtCrPos1 thePic cr = (,) mempty $ tranRot (_crPos cr) (_crDir cr) thePic
|
||||
|
||||
shiftDraw :: (a -> Point2) -> (a -> Float) -> (a -> a -> SPic) -> a -> SPic
|
||||
shiftDraw fpos fdir fdraw x = uncurryV translateSPf (fpos x)
|
||||
. rotateSP (fdir x)
|
||||
$ fdraw x x
|
||||
shiftDraw fpos fdir fdraw x =
|
||||
uncurryV translateSPf (fpos x)
|
||||
. rotateSP (fdir x)
|
||||
$ fdraw x x
|
||||
|
||||
shiftDraw' :: (a -> Point2) -> (a -> Float) -> (a -> SPic) -> a -> SPic
|
||||
shiftDraw' fpos fdir fdraw x = uncurryV translateSPf (fpos x)
|
||||
. rotateSP (fdir x)
|
||||
$ fdraw x
|
||||
shiftDraw' fpos fdir fdraw x =
|
||||
uncurryV translateSPf (fpos x)
|
||||
. rotateSP (fdir x)
|
||||
$ fdraw x
|
||||
|
||||
cullPoint :: Configuration -> World -> Point2 -> Bool
|
||||
cullPoint cfig w p
|
||||
cullPoint cfig w p
|
||||
| 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 (_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 (_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 (_cWorld w) )
|
||||
<> concatMapPic ppDraw (_pressPlates (_cWorld w) )
|
||||
<> viewClipBounds cfig w
|
||||
<> debugDraw cfig 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 (_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 (_cWorld w))
|
||||
<> concatMapPic ppDraw (_pressPlates (_cWorld w))
|
||||
<> viewClipBounds cfig w
|
||||
<> debugDraw cfig w
|
||||
|
||||
debugDraw :: Configuration -> World -> Picture
|
||||
{-# INLINE debugDraw #-}
|
||||
debugDraw cfig w
|
||||
debugDraw cfig w
|
||||
| Show_debug `Set.member` _debug_booleans cfig =
|
||||
pic
|
||||
<>
|
||||
setLayer FixedCoordLayer (listPicturesAt (0.5*halfWidth cfig) 0 cfig $ map text ts)
|
||||
<> setLayer FixedCoordLayer (listPicturesAt (0.5 * halfWidth cfig) 0 cfig $ map text ts)
|
||||
| otherwise = mempty
|
||||
where
|
||||
(ts, pic) = foldMap (debugDraw' cfig w) (_debug_booleans cfig)
|
||||
|
||||
debugDraw' :: Configuration -> World -> DebugBool -> ([String],Picture)
|
||||
debugDraw' :: Configuration -> World -> DebugBool -> ([String], Picture)
|
||||
{-# INLINE debugDraw' #-}
|
||||
debugDraw' cfig w bl = case bl of
|
||||
Show_debug -> lstring "Show debug"
|
||||
Noclip -> lstring "Noclip"
|
||||
Remove_LOS -> lstring "No line of sight"
|
||||
Cull_more_lights -> lstring "Cull more lights"
|
||||
Show_debug -> lstring "Show debug"
|
||||
Noclip -> lstring "Noclip"
|
||||
Remove_LOS -> lstring "No line of sight"
|
||||
Cull_more_lights -> lstring "Cull more lights"
|
||||
Close_shape_culling -> lstring "Close shape culling"
|
||||
Bound_box_screen -> lstring "bound box screen, this should be moved"
|
||||
Show_ms_frame -> rdraw mempty
|
||||
View_boundaries -> rdraw $ viewBoundaries w
|
||||
Show_bound_box -> rdraw $ drawBoundingBox w
|
||||
Show_wall_search_rays -> rdraw $ drawWallSearchRays w
|
||||
Show_dda_test -> rdraw $ drawDDATest w
|
||||
Show_far_wall_detect -> rdraw $ drawFarWallDetect w
|
||||
Show_select -> rdraw $ drawWorldSelect w
|
||||
Inspect_wall -> rdraw $ drawInspectWalls w
|
||||
Cr_awareness -> rdraw $ drawCreatureDisplayTexts w
|
||||
Show_sound -> rdraw $ pictures $ M.map (soundPic cfig w) $ _playingSounds w
|
||||
Cr_status -> rdraw $ drawCrInfo cfig w
|
||||
Mouse_position -> rdraw $ drawMousePosition cfig w
|
||||
Walls_info -> rdraw $ drawWlIDs cfig w
|
||||
Pathing -> rdraw $ drawPathing cfig w
|
||||
Show_nodes_near_select -> rdraw $ drawNodesNearSelect w
|
||||
Show_path_between -> rdraw $ drawPathBetween w
|
||||
Bound_box_screen -> lstring "bound box screen, this should be moved"
|
||||
Show_ms_frame -> rdraw mempty
|
||||
View_boundaries -> rdraw $ viewBoundaries w
|
||||
Show_bound_box -> rdraw $ drawBoundingBox w
|
||||
Show_wall_search_rays -> rdraw $ drawWallSearchRays w
|
||||
Show_dda_test -> rdraw $ drawDDATest w
|
||||
Show_far_wall_detect -> rdraw $ drawFarWallDetect w
|
||||
Show_select -> rdraw $ drawWorldSelect w
|
||||
Inspect_wall -> rdraw $ drawInspectWalls w
|
||||
Cr_awareness -> rdraw $ drawCreatureDisplayTexts w
|
||||
Show_sound -> rdraw $ pictures $ M.map (soundPic cfig w) $ _playingSounds w
|
||||
Cr_status -> rdraw $ drawCrInfo cfig w
|
||||
Mouse_position -> rdraw $ drawMousePosition cfig w
|
||||
Walls_info -> rdraw $ drawWlIDs cfig w
|
||||
Pathing -> rdraw $ drawPathing cfig w
|
||||
Show_nodes_near_select -> rdraw $ drawNodesNearSelect w
|
||||
Show_path_between -> rdraw $ drawPathBetween w
|
||||
where
|
||||
lstring str = ([str],mempty)
|
||||
rdraw pic = (mempty,pic)
|
||||
lstring str = ([str], mempty)
|
||||
rdraw pic = (mempty, pic)
|
||||
|
||||
drawCreatureDisplayTexts :: World -> Picture
|
||||
drawCreatureDisplayTexts w = foldMap (creatureDisplayText w) (_creatures (_cWorld w))
|
||||
|
||||
drawPathBetween :: World -> Picture
|
||||
drawPathBetween w = setLayer DebugLayer
|
||||
$ color rose (foldMap (arrowPath . mapMaybe nodepos) nodelist)
|
||||
<> foldMap (color green . arrow sp) (nodepos =<< walkableNodeNear w sp)
|
||||
<> foldMap (color cyan . flip arrow ep) (nodepos =<< walkableNodeNear w ep)
|
||||
<> foldMap (color orange . arrow sp) (pointTowardsImpulse sp ep w)
|
||||
drawPathBetween w =
|
||||
setLayer DebugLayer $
|
||||
color rose (foldMap (arrowPath . mapMaybe nodepos) nodelist)
|
||||
<> foldMap (color green . arrow sp) (nodepos =<< walkableNodeNear w sp)
|
||||
<> foldMap (color cyan . flip arrow ep) (nodepos =<< walkableNodeNear w ep)
|
||||
<> foldMap (color orange . arrow sp) (pointTowardsImpulse sp ep w)
|
||||
where
|
||||
nodepos = (`getNodePos` w)
|
||||
nodelist = makePathBetween sp ep w
|
||||
@@ -211,25 +219,28 @@ drawPathBetween w = setLayer DebugLayer
|
||||
ep = _rSelect w
|
||||
|
||||
drawNodesNearSelect :: World -> Picture
|
||||
drawNodesNearSelect w = setLayer DebugLayer
|
||||
$ runIdentity (S.foldMap_ (drawZoneCol orange pnZoneSize) (zoneAroundPoint pnZoneSize sp))
|
||||
<> color green (drawCross sp)
|
||||
drawNodesNearSelect w =
|
||||
setLayer DebugLayer $
|
||||
runIdentity (S.foldMap_ (drawZoneCol orange pnZoneSize) (zoneAroundPoint pnZoneSize sp))
|
||||
<> color green (drawCross sp)
|
||||
where
|
||||
sp = _lSelect w
|
||||
|
||||
drawInspectWalls :: World -> Picture
|
||||
drawInspectWalls w = foldMap (drawInspectWall w)
|
||||
$ filter (isJust . uncurry (intersectSegSeg a b) . _wlLine)
|
||||
$ IM.elems $ _walls (_cWorld w)
|
||||
drawInspectWalls w =
|
||||
foldMap (drawInspectWall w) $
|
||||
filter (isJust . uncurry (intersectSegSeg a b) . _wlLine) $
|
||||
IM.elems $ _walls (_cWorld w)
|
||||
where
|
||||
(a,b) = _lLine w
|
||||
(a, b) = _lLine w
|
||||
|
||||
drawInspectWall :: World -> Wall -> Picture
|
||||
drawInspectWall w wl = setLayer DebugLayer
|
||||
$ color rose (thickLine 3 [a,b])
|
||||
<> foldMap (drawDoorPaths w) (wl ^? wlStructure . wsDoor)
|
||||
drawInspectWall w wl =
|
||||
setLayer DebugLayer $
|
||||
color rose (thickLine 3 [a, b])
|
||||
<> foldMap (drawDoorPaths w) (wl ^? wlStructure . wsDoor)
|
||||
where
|
||||
(a,b) = _wlLine wl
|
||||
(a, b) = _wlLine wl
|
||||
|
||||
drawDoorPaths :: World -> Int -> Picture
|
||||
drawDoorPaths w drid = fromMaybe mempty $ do
|
||||
@@ -237,60 +248,68 @@ drawDoorPaths w drid = fromMaybe mempty $ do
|
||||
return $ foldMap (drawPathEdge . (^. _3)) paths
|
||||
|
||||
drawPathEdge :: PathEdge -> Picture
|
||||
drawPathEdge pe = setLayer DebugLayer
|
||||
$ multiArrow (_peStart pe) (_peEnd pe) green (Set.map obstacleColor (_peObstacles pe))
|
||||
drawPathEdge pe =
|
||||
setLayer DebugLayer $
|
||||
multiArrow (_peStart pe) (_peEnd pe) green (Set.map obstacleColor (_peObstacles pe))
|
||||
|
||||
obstacleColor :: EdgeObstacle -> Color
|
||||
obstacleColor eo = case eo of
|
||||
WallObstacle -> cyan
|
||||
DoorObstacle -> red
|
||||
WallObstacle -> cyan
|
||||
DoorObstacle -> red
|
||||
AutoDoorObstacle -> yellow
|
||||
BlockObstacle -> blue
|
||||
|
||||
drawWorldSelect :: World -> Picture
|
||||
drawWorldSelect w = setLayer DebugLayer
|
||||
$ color cyan (line [a,b])
|
||||
<> color magenta (line [c,d])
|
||||
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 w
|
||||
(c, d) = _rLine w
|
||||
|
||||
drawFarWallDetect :: World -> Picture
|
||||
drawFarWallDetect w = setLayer DebugLayer
|
||||
. color yellow
|
||||
. foldMap (\q -> line
|
||||
[ p
|
||||
, fst $ collidePoint p q $ filter wlIsOpaque $ wlsNearSeg p q w
|
||||
] )
|
||||
$ runIdentity $ S.toList_ $ streamViewpoints p w
|
||||
drawFarWallDetect w =
|
||||
setLayer DebugLayer
|
||||
. color yellow
|
||||
. foldMap
|
||||
( \q ->
|
||||
line
|
||||
[ p
|
||||
, fst $ collidePoint p q $ filter wlIsOpaque $ wlsNearSeg p q w
|
||||
]
|
||||
)
|
||||
$ runIdentity $ S.toList_ $ streamViewpoints p w
|
||||
where
|
||||
p = _cameraViewFrom (_cWorld w)
|
||||
|
||||
drawDDATest :: World -> Picture
|
||||
drawDDATest w = runIdentity (S.foldMap_ (drawZoneCol orange 50) ps)
|
||||
<> runIdentity (S.foldMap_ (drawZoneCol green 50) ps')
|
||||
<> runIdentity (S.foldMap_ drawCross qs)
|
||||
<> color blue (runIdentity (S.foldMap_ drawCross qs'))
|
||||
<> setLayer DebugLayer (color yellow (line [cvf,mwp]))
|
||||
drawDDATest w =
|
||||
runIdentity (S.foldMap_ (drawZoneCol orange 50) ps)
|
||||
<> runIdentity (S.foldMap_ (drawZoneCol green 50) ps')
|
||||
<> runIdentity (S.foldMap_ drawCross qs)
|
||||
<> color blue (runIdentity (S.foldMap_ drawCross qs'))
|
||||
<> setLayer DebugLayer (color yellow (line [cvf, mwp]))
|
||||
where
|
||||
cvf = _cameraViewFrom (_cWorld w)
|
||||
mwp = mouseWorldPos w
|
||||
ps = ddaStreamX 50 cvf mwp
|
||||
ps' = ddaStreamY 50 (_cameraViewFrom (_cWorld w)) (mouseWorldPos w)
|
||||
qs = xIntercepts 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
|
||||
|
||||
crossPic :: Float -> Picture
|
||||
crossPic x = line [V2 x x,V2 (-x) (-x)] <> line [V2 (-x) x,V2 x (-x)]
|
||||
crossPic x = line [V2 x x, V2 (- x) (- x)] <> line [V2 (- x) x, V2 x (- x)]
|
||||
|
||||
drawZoneCol :: Color -> Float -> V2 Int -> Picture
|
||||
drawZoneCol col s (V2 x y) = setLayer DebugLayer . color col $ thickLine 2 (p:ps ++ [p])
|
||||
drawZoneCol col s (V2 x y) = setLayer DebugLayer . color col $ 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)]
|
||||
(p : ps) =
|
||||
zipWith (+.+) innerSquare $
|
||||
map ((s *.*) . (each %~ fromIntegral)) [V2 x y, V2 (x + 1) y, V2 (x + 1) (y + 1), V2 x (y + 1)]
|
||||
|
||||
innerSquare :: [Point2]
|
||||
innerSquare = [V2 1 1, V2 (-1) 1, V2 (-1) (-1), V2 1 (-1)]
|
||||
@@ -298,51 +317,61 @@ innerSquare = [V2 1 1, V2 (-1) 1, V2 (-1) (-1), V2 1 (-1)]
|
||||
drawWallSearchRays :: World -> Picture
|
||||
drawWallSearchRays w = foldMap (f . fst) $ allVisibleWalls w
|
||||
where
|
||||
f p = setLayer DebugLayer $ color yellow $ uncurryV translate p (circle 5)
|
||||
<> line [_cameraViewFrom (_cWorld w), p]
|
||||
f p =
|
||||
setLayer DebugLayer $
|
||||
color yellow $
|
||||
uncurryV translate p (circle 5)
|
||||
<> line [_cameraViewFrom (_cWorld w), p]
|
||||
|
||||
testPic :: Configuration -> World -> Picture
|
||||
testPic _ _ = mempty
|
||||
|
||||
drawBoundingBox :: World -> Picture
|
||||
drawBoundingBox w = setLayer DebugLayer $ color green $ line $ (x:xs) ++ [x]
|
||||
drawBoundingBox w = setLayer DebugLayer $ color green $ line $ (x : xs) ++ [x]
|
||||
where
|
||||
(x:xs) = _boundBox (_cWorld w)
|
||||
(x : xs) = _boundBox (_cWorld w)
|
||||
|
||||
clDraw :: Cloud -> Picture
|
||||
clDraw c = translate3 (_clPos c) (drawCloud (_clPict c) c)
|
||||
|
||||
ppDraw :: PressPlate -> Picture
|
||||
ppDraw c = uncurryV translate (_ppPos c) $ rotate (_ppRot c) (_ppPict c)
|
||||
|
||||
floorItemSPic :: FloorItem -> SPic
|
||||
floorItemSPic flit = uncurryV translateSPf (_flItPos flit)
|
||||
$ rotateSP (_flItRot flit) (itemSPic (_flIt flit))
|
||||
floorItemSPic flit =
|
||||
uncurryV translateSPf (_flItPos flit) $
|
||||
rotateSP (_flItRot flit) (itemSPic (_flIt flit))
|
||||
|
||||
btSPic :: Button -> SPic
|
||||
btSPic bt = uncurryV translateSPf (_btPos bt)
|
||||
$ rotateSP (_btRot bt) (drawButton (_btPict bt) bt)
|
||||
btSPic bt =
|
||||
uncurryV translateSPf (_btPos bt) $
|
||||
rotateSP (_btRot bt) (drawButton (_btPict bt) bt)
|
||||
|
||||
mcSPic :: Machine -> SPic
|
||||
mcSPic mc = uncurryV translateSPf (_mcPos mc)
|
||||
$ rotateSP (_mcDir mc) (drawMachine mc)
|
||||
mcSPic mc =
|
||||
uncurryV translateSPf (_mcPos mc) $
|
||||
rotateSP (_mcDir mc) (drawMachine mc)
|
||||
|
||||
soundPic :: Configuration -> World -> Sound -> Picture
|
||||
soundPic cfig w s = fixedSizePicClampArrow 50 50 thePic p cfig w
|
||||
where
|
||||
p = _soundPos s
|
||||
thePic
|
||||
= rotate (_cameraRot (_cWorld w))
|
||||
. scale theScale theScale
|
||||
. centerText
|
||||
. soundToOnomato
|
||||
$ _soundChunkID s
|
||||
thePic =
|
||||
rotate (_cameraRot (_cWorld w))
|
||||
. scale theScale theScale
|
||||
. centerText
|
||||
. soundToOnomato
|
||||
$ _soundChunkID s
|
||||
theScale = 0.15 * f (_soundVolume s * 0.0001)
|
||||
f x = 1 - 0.5 * (1 - x)
|
||||
|
||||
drawMousePosition :: Configuration -> World -> Picture
|
||||
drawMousePosition cfig w = setLayer FixedCoordLayer . winScale cfig
|
||||
. uncurryV translate p
|
||||
. scale 0.1 0.1
|
||||
. text
|
||||
$ shortPoint2 mwp
|
||||
drawMousePosition cfig w =
|
||||
setLayer FixedCoordLayer . winScale cfig
|
||||
. uncurryV translate p
|
||||
. scale 0.1 0.1
|
||||
. text
|
||||
$ shortPoint2 mwp
|
||||
where
|
||||
p = worldPosToScreen w mwp
|
||||
mwp = mouseWorldPos w
|
||||
@@ -350,13 +379,14 @@ drawMousePosition cfig w = setLayer FixedCoordLayer . winScale cfig
|
||||
drawWlIDs :: Configuration -> World -> Picture
|
||||
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"
|
||||
| otherwise = winScale cfig
|
||||
. uncurryV translate p
|
||||
. scale 0.1 0.1
|
||||
. text
|
||||
$ show $ _wlID wl
|
||||
f wl
|
||||
| dist (_crPos $ you w) (fst (_wlLine wl)) > 200 = mempty -- this should be improved with a better "on screen test"
|
||||
| otherwise =
|
||||
winScale cfig
|
||||
. uncurryV translate p
|
||||
. scale 0.1 0.1
|
||||
. text
|
||||
$ show $ _wlID wl
|
||||
where
|
||||
p = worldPosToScreen w $ 0.5 *.* uncurry (+.+) (_wlLine wl)
|
||||
|
||||
@@ -369,78 +399,87 @@ edgeToPic poly pe
|
||||
ep = _peEnd pe
|
||||
|
||||
drawPathing :: Configuration -> World -> Picture
|
||||
drawPathing cfig w = setLayer DebugLayer
|
||||
$ foldMap (edgeToPic (screenPolygon cfig w) . (^?! _3)) (FGL.labEdges gr)
|
||||
<> foldMap dispInc (graphToIncidence gr)
|
||||
drawPathing cfig w =
|
||||
setLayer DebugLayer $
|
||||
foldMap (edgeToPic (screenPolygon cfig w) . (^?! _3)) (FGL.labEdges gr)
|
||||
<> foldMap dispInc (graphToIncidence gr)
|
||||
where
|
||||
dispInc (p,n) = setDepth 2 . uncurryV translate p . scale 0.1 0.1 $ text $ show n
|
||||
dispInc (p, n) = setDepth 2 . uncurryV translate p . scale 0.1 0.1 $ text $ show n
|
||||
gr = _pathGraph (_cWorld w)
|
||||
|
||||
crDisplayInfo :: Configuration -> World -> Creature -> Maybe (Point2,[String])
|
||||
crDisplayInfo cfig w cr
|
||||
crDisplayInfo :: Configuration -> World -> Creature -> Maybe (Point2, [String])
|
||||
crDisplayInfo cfig w cr
|
||||
| _crID cr == 0 = Nothing
|
||||
| crOnScreen = Just (_crPos cr, catMaybes
|
||||
-- [fmap show $ ap ^? crGoal
|
||||
[ fpreShow "crHP" $ cr ^? crHP
|
||||
, fpreShow "crStrategy" $ ap ^? apStrategy
|
||||
, fmap (("crPos....." ++) . shortShow) $ cr ^? crPos
|
||||
, fpreShow "cpVigilance" $ cr ^? crPerception . cpVigilance
|
||||
-- , fmap show $ cr ^? crOldPos
|
||||
, fpreShow "crAction" $ ap ^? apAction
|
||||
, fpreShow "crImpulse" $ ap ^? apImpulse
|
||||
]
|
||||
)
|
||||
| crOnScreen =
|
||||
Just
|
||||
( _crPos cr
|
||||
, catMaybes
|
||||
-- [fmap show $ ap ^? crGoal
|
||||
[ fpreShow "crHP" $ cr ^? crHP
|
||||
, fpreShow "crStrategy" $ ap ^? apStrategy
|
||||
, fmap (("crPos....." ++) . shortShow) $ cr ^? crPos
|
||||
, fpreShow "cpVigilance" $ cr ^? crPerception . cpVigilance
|
||||
, -- , fmap show $ cr ^? crOldPos
|
||||
fpreShow "crAction" $ ap ^? apAction
|
||||
, fpreShow "crImpulse" $ ap ^? apImpulse
|
||||
]
|
||||
)
|
||||
| otherwise = Nothing
|
||||
where
|
||||
ap = _crActionPlan cr
|
||||
crOnScreen = pointOnScreen cfig w $ _crPos cr
|
||||
|
||||
fpreShow :: (Show a,Functor f) => String -> f a -> f String
|
||||
fpreShow str = fmap (((rightPad 7 '.'str ++ "...") ++) . show)
|
||||
fpreShow :: (Show a, Functor f) => String -> f a -> f String
|
||||
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 (_cWorld w)
|
||||
drawCrInfo cfig w =
|
||||
setLayer FixedCoordLayer $
|
||||
renderInfoListsAt (2 * hw - 400) 0 cfig w $
|
||||
mapMaybe (crDisplayInfo cfig w) $ IM.elems $ _creatures (_cWorld w)
|
||||
where
|
||||
hw = halfWidth cfig
|
||||
|
||||
viewBoundaries :: World -> Picture
|
||||
viewBoundaries w = setLayer DebugLayer $ color green (foldMap (polygonWire . _grBound) grs)
|
||||
<> color yellow (foldMap (\q -> line [p,q]) $ farWallPoints p w)
|
||||
viewBoundaries w =
|
||||
setLayer DebugLayer $
|
||||
color green (foldMap (polygonWire . _grBound) grs)
|
||||
<> color yellow (foldMap (\q -> line [p, q]) $ farWallPoints p w)
|
||||
where
|
||||
p = _crPos $ you 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 (_cWorld w))
|
||||
| _debug_view_clip_bounds cfig == IntersectingRoomClipBoundaries
|
||||
= setLayer DebugLayer $ f (_roomClipping (_cWorld w))
|
||||
| _debug_view_clip_bounds cfig == AllRoomClipBoundaries =
|
||||
setLayer DebugLayer $ color green $ foldMap (polygonWire . _cpPoints) (_roomClipping (_cWorld w))
|
||||
| _debug_view_clip_bounds cfig == IntersectingRoomClipBoundaries =
|
||||
setLayer DebugLayer $ f (_roomClipping (_cWorld w))
|
||||
| otherwise = mempty
|
||||
where
|
||||
f (x:xs) = g x xs <> f xs
|
||||
f (x : xs) = g x xs <> f xs
|
||||
f [] = mempty
|
||||
g x (y:ys) | convexPolysOverlap x y = color green (polygonWire $ _cpPoints x)
|
||||
<> color yellow (polygonWire $ _cpPoints y)
|
||||
<> g x ys
|
||||
g x (y : ys)
|
||||
| convexPolysOverlap x y =
|
||||
color green (polygonWire $ _cpPoints x)
|
||||
<> color yellow (polygonWire $ _cpPoints y)
|
||||
<> g x ys
|
||||
| otherwise = g x ys
|
||||
g _ [] = mempty
|
||||
|
||||
--wallFloorsToDraw :: World -> [Wall]
|
||||
--wallFloorsToDraw w = filter isVisible $ IM.elems $ wallsOnScreen w
|
||||
-- where
|
||||
-- where
|
||||
-- onScreen wall = uncurry (lineOnScreen w) $ _wlLine wall
|
||||
-- isVisible wl
|
||||
-- isVisible wl
|
||||
-- | wl ^? wlUnshadowed == Just False = False
|
||||
-- | otherwise = onScreen wl
|
||||
--
|
||||
--lineOnScreen :: World -> Point2 -> Point2 -> Bool
|
||||
--lineOnScreen w p1 p2 = pointInPolygon p1 sp
|
||||
-- || pointInPolygon p2 sp
|
||||
--lineOnScreen w p1 p2 = pointInPolygon p1 sp
|
||||
-- || pointInPolygon p2 sp
|
||||
-- || any (isJust . uncurry (intersectSegSeg p1 p2)) sps
|
||||
-- where
|
||||
-- where
|
||||
-- sp = screenPolygon w
|
||||
-- sps = zip sp (tail sp ++ [head sp])
|
||||
--
|
||||
@@ -448,7 +487,7 @@ viewClipBounds cfig w
|
||||
--drawWallFloor wl = if _wlOpacity wl == SeeThrough
|
||||
-- then setDepth 0.9 . color c $ polygon [x,x +.+ n2,y+.+n2, y]
|
||||
-- else blank
|
||||
-- where
|
||||
-- where
|
||||
-- (x,y) = _wlLine wl
|
||||
-- c = _wlColor wl
|
||||
-- n2 = 15 *.* (vNormal . errorNormalizeVDR $ y -.- x)
|
||||
|
||||
Reference in New Issue
Block a user