Files
loop/src/Dodge/Render/ShapePicture.hs
T
2022-07-27 12:49:23 +01:00

459 lines
17 KiB
Haskell

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.Data
import Dodge.Zone
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
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
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)
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)
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
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)
]
where
f pos = Verx (pos -.-.- V3 2.5 2.5 0) blue [] BottomLayer polyNum
--DrawnCreature f -> f cr
--
picAtCrPosNoRot1 :: Picture -> Creature -> SPic
--{-# INLINE picAtCrPos #-}
picAtCrPosNoRot1 thePic cr = (,) mempty $ uncurryV translate (_crPos cr) thePic
picAtCrPos1 :: Picture -> Creature -> SPic
--{-# INLINE picAtCrPos #-}
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' :: (a -> Point2) -> (a -> Float) -> (a -> SPic) -> a -> SPic
shiftDraw' fpos fdir fdraw x = uncurryV translateSPf (fpos x)
. rotateSP (fdir x)
$ fdraw x
cullPoint :: Configuration -> World -> Point2 -> Bool
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
debugDraw :: Configuration -> World -> Picture
{-# INLINE debugDraw #-}
debugDraw cfig w
| Show_debug `Set.member` _debug_booleans cfig =
pic
<>
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)
{-# 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"
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
where
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)
where
nodepos = (`getNodePos` w)
nodelist = makePathBetween sp ep w
sp = _lSelect w
ep = _rSelect 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
drawInspectWalls :: World -> Picture
drawInspectWalls w = foldMap (drawInspectWall w)
$ filter (isJust . uncurry (intersectSegSeg a b) . _wlLine)
$ IM.elems $ _walls (_cWorld w)
where
(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)
where
(a,b) = _wlLine wl
drawDoorPaths :: World -> Int -> Picture
drawDoorPaths w drid = fromMaybe mempty $ do
paths <- w ^? cWorld . doors . ix drid . drObstructs
return $ foldMap (drawPathEdge . (^. _3)) paths
drawPathEdge :: PathEdge -> Picture
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
AutoDoorObstacle -> yellow
BlockObstacle -> blue
drawWorldSelect :: World -> Picture
drawWorldSelect w = setLayer DebugLayer
$ color cyan (line [a,b])
<> color magenta (line [c,d])
where
(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
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]))
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' = 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)]
drawZoneCol :: Color -> Float -> V2 Int -> Picture
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)]
innerSquare :: [Point2]
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]
testPic :: Configuration -> World -> Picture
testPic _ _ = mempty
drawBoundingBox :: World -> Picture
drawBoundingBox w = setLayer DebugLayer $ color green $ line $ (x:xs) ++ [x]
where
(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))
btSPic :: Button -> SPic
btSPic bt = uncurryV translateSPf (_btPos bt)
$ rotateSP (_btRot bt) (drawButton (_btPict bt) bt)
mcSPic :: Machine -> SPic
mcSPic bt = uncurryV translateSPf (_mcPos bt)
$ rotateSP (_mcDir bt) (drawMachine (_mcDraw bt) bt)
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
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
where
p = worldPosToScreen w mwp
mwp = mouseWorldPos w
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
where
p = worldPosToScreen w $ 0.5 *.* uncurry (+.+) (_wlLine wl)
edgeToPic :: [Point2] -> PathEdge -> Picture
edgeToPic poly pe
| not (pointInPolygon sp poly) && not (pointInPolygon ep poly) = mempty
| otherwise = drawPathEdge pe
where
sp = _peStart 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)
where
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
| _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
]
)
| 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)
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)
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)
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))
| otherwise = mempty
where
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
| otherwise = g x ys
g _ [] = mempty
--wallFloorsToDraw :: World -> [Wall]
--wallFloorsToDraw w = filter isVisible $ IM.elems $ wallsOnScreen w
-- where
-- onScreen wall = uncurry (lineOnScreen w) $ _wlLine wall
-- 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
-- || any (isJust . uncurry (intersectSegSeg p1 p2)) sps
-- where
-- sp = screenPolygon w
-- sps = zip sp (tail sp ++ [head sp])
--
--drawWallFloor :: Wall -> Picture
--drawWallFloor wl = if _wlOpacity wl == SeeThrough
-- then setDepth 0.9 . color c $ polygon [x,x +.+ n2,y+.+n2, y]
-- else blank
-- where
-- (x,y) = _wlLine wl
-- c = _wlColor wl
-- n2 = 15 *.* (vNormal . errorNormalizeVDR $ y -.- x)
--
--errorNormalizeVDR :: Point2 -> Point2
--errorNormalizeVDR (V2 0 0) = error "problem with function: errorNormalizeVDR in DodgeRendering"
--errorNormalizeVDR p = normalizeV p