393 lines
14 KiB
Haskell
393 lines
14 KiB
Haskell
module Dodge.Render.ShapePicture
|
|
( worldSPic
|
|
) where
|
|
import Dodge.Creature.Picture.Awareness
|
|
import Dodge.ShortShow
|
|
import Dodge.Config.Data
|
|
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
|
|
import Dodge.Graph
|
|
import Dodge.GameRoom
|
|
import Dodge.Update.Camera
|
|
import Dodge.Item.Draw
|
|
import Dodge.Render.List
|
|
import Dodge.Path
|
|
--import Dodge.Zone
|
|
import Geometry
|
|
import Geometry.Zone
|
|
import ShapePicture
|
|
import Picture
|
|
import Sound.Data
|
|
import Geometry.ConvexPoly
|
|
--import Dodge.Base.Collide
|
|
|
|
--import Data.Foldable
|
|
import qualified Data.IntMap.Strict as IM -- Lazy?
|
|
import qualified Data.Map.Strict as M
|
|
--import qualified Data.Set as Set
|
|
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
|
|
|
|
-- TODO only filter out shapes outside the range of the furthest shown light source
|
|
worldSPic :: Configuration -> World -> SPic
|
|
worldSPic 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 (dbArg _cpPict) (filtOn _cpPos _corpses)
|
|
<> foldMap (dbArg _crPict) (filtOn _crPos _creatures)
|
|
<> foldMap floorItemSPic (filtOn _flItPos _floorItems)
|
|
<> foldMap btSPic (filtOn _btPos _buttons)
|
|
<> foldMap mcSPic (filtOn _mcPos _machines)
|
|
<> anyTargeting cfig w
|
|
where
|
|
filtOn f g = IM.filter (pointIsClose . f) (g 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 -> g it cr cfig w) (it ^? itTargeting . tgDraw)
|
|
|
|
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
|
|
|
|
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
|
|
|
|
extraPics :: Configuration -> World -> Picture
|
|
extraPics cfig w = pictures (_decorations w)
|
|
<> concatMapPic (dbArg _ptDraw) (_particles w)
|
|
<> concatMapPic (dbArg _bmDraw) (_positronBeams $ _beams w)
|
|
<> concatMapPic (dbArg _bmDraw) (_electronBeams $ _beams w)
|
|
<> concatMapPic (dbArg _lsPict) (_lightSources w)
|
|
<> testPic cfig w
|
|
<> concatMapPic clDraw (_clouds w )
|
|
<> concatMapPic ppDraw (_pressPlates w )
|
|
<> viewClipBounds cfig w
|
|
<> debugDraw cfig w
|
|
|
|
debugDraw :: Configuration -> World -> Picture
|
|
{-# INLINE debugDraw #-}
|
|
debugDraw cfig w =
|
|
pic
|
|
<>
|
|
setLayer FixedCoordLayer (listPicturesAt (0.5*halfWidth cfig) 0 cfig $ map text ts)
|
|
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
|
|
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 w)
|
|
|
|
drawPathBetween :: World -> Picture
|
|
drawPathBetween w = setLayer DebugLayer
|
|
$ color yellow (foldMap (arrowPath . mapMaybe nodepos) nodelist)
|
|
<> foldMap (color green . arrow sp) (nodepos =<< walkableNodeNear w sp)
|
|
<> foldMap (color cyan . flip arrow ep) (nodepos =<< walkableNodeNear w ep)
|
|
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_ (drawZone pnZoneSize) (zoneAroundPoint pnZoneSize sp))
|
|
-- <> color red (foldMap (drawCross . snd) $ nodesNearL sp w)
|
|
<> color green (drawCross sp)
|
|
-- <> color cyan (foldMap (drawCross . snd) $ walkableNodeNear sp w)
|
|
where
|
|
sp = _lSelect w
|
|
|
|
drawInspectWalls :: World -> Picture
|
|
drawInspectWalls w = foldMap (drawInspectWall w)
|
|
$ filter (isJust . uncurry (intersectSegSeg a b) . _wlLine)
|
|
$ IM.elems $ _walls w
|
|
where
|
|
(a,b) = _lLine w
|
|
|
|
drawInspectWall :: World -> Wall -> Picture
|
|
drawInspectWall w wl = setLayer DebugLayer $
|
|
color rose (thickLine 3 [a,b])
|
|
-- <> foldMap (drawZone wlZoneSize)
|
|
-- (runIdentity $ S.toList_ $ zoneOfWall wlZoneSize wl) -- this won't work if wlZoneSize is not consistent
|
|
<> foldMap (drawDoorPaths w) (wl ^? wlStructure . wsDoor)
|
|
where
|
|
(a,b) = _wlLine wl
|
|
|
|
drawDoorPaths :: World -> Int -> Picture
|
|
drawDoorPaths w drid = fromMaybe mempty $ do
|
|
paths <- w ^? doors . ix drid . drObstructs
|
|
-- path <- listToMaybe paths
|
|
-- undefined
|
|
return $ foldMap (drawPathEdge . (^. _3)) paths
|
|
-- return $ (drawPathEdge . (^. _3)) path
|
|
|
|
drawPathEdge :: PathEdge -> Picture
|
|
drawPathEdge pe = setLayer DebugLayer $ color col $ arrow (_peStart pe) (_peEnd pe)
|
|
where
|
|
col = case _peObstacles pe of
|
|
pos | WallObstacle `Set.member` pos -> blue
|
|
| True -> red
|
|
|
|
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
|
|
. concatMap (\q -> line
|
|
[ p
|
|
, fst $ collidePoint p q $ S.filter wlIsOpaque $ wlsNearSeg 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')
|
|
<> runIdentity (S.foldMap_ drawCross qs)
|
|
<> color blue (runIdentity (S.foldMap_ drawCross qs'))
|
|
<> setLayer DebugLayer (color yellow (line [cvf,mwp]))
|
|
where
|
|
cvf = _cameraViewFrom 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)
|
|
|
|
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)]
|
|
|
|
drawZone :: Float -> V2 Int -> Picture
|
|
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)]
|
|
|
|
drawZone' :: Float -> V2 Int -> Picture
|
|
drawZone' s (V2 x y) = setLayer DebugLayer . color green $ line (p:ps ++ [p])
|
|
where
|
|
(p:ps) = zipWith (+.+) (map (2*.*) 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 = runIdentity $ S.foldMap_ f $ S.map fst $ allVisibleWalls w
|
|
where
|
|
f p = setLayer DebugLayer $ color yellow $ uncurryV translate p (circle 5)
|
|
<> line [_cameraViewFrom 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 w
|
|
|
|
clDraw :: Cloud -> Picture
|
|
clDraw c = translate3 (_clPos c) (_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) (itSPic (_flIt flit))
|
|
|
|
btSPic :: Button -> SPic
|
|
btSPic bt = uncurryV translateSPf (_btPos bt)
|
|
$ rotateSP (_btRot bt) (_btPict bt bt)
|
|
mcSPic :: Machine -> SPic
|
|
mcSPic bt = uncurryV translateSPf (_mcPos bt)
|
|
$ rotateSP (_mcDir bt) (_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 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 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
|
|
| null $ _peObstacles pe
|
|
= anarrow green
|
|
| hasobstacle BlockObstacle
|
|
= anarrow red
|
|
| hasobstacle AutoDoorObstacle = anarrow yellow
|
|
| otherwise = anarrow cyan
|
|
where
|
|
hasobstacle = (`Set.member` _peObstacles pe)
|
|
anarrow col = color col $ arrow sp ep
|
|
sp = _peStart pe
|
|
ep = _peEnd pe
|
|
|
|
drawPathing :: Configuration -> World -> Picture
|
|
drawPathing cfig w = setLayer DebugLayer
|
|
$ foldMap (edgeToPic (screenPolygon cfig w) . (^?! _3)) (FGL.labEdges gr)
|
|
<> concatMap dispInc (graphToIncidence gr)
|
|
where
|
|
dispInc (p,n) = setDepth 2 . uncurryV translate p . scale 0.1 0.1 $ text $ show n
|
|
gr = _pathGraph 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
|
|
[ fmap show $ cr ^? crHP
|
|
, fmap show $ ap ^? crStrategy
|
|
, fmap show $ cr ^? crPos
|
|
, fmap show $ cr ^? crPerception . cpVigilance
|
|
-- , fmap show $ cr ^? crOldPos
|
|
, fmap show $ ap ^? crAction
|
|
, fmap show $ ap ^? crImpulse
|
|
]
|
|
)
|
|
| otherwise = Nothing
|
|
where
|
|
ap = _crActionPlan cr
|
|
crOnScreen = pointOnScreen cfig w $ _crPos cr
|
|
|
|
drawCrInfo :: Configuration -> World -> Picture
|
|
drawCrInfo cfig w = setLayer FixedCoordLayer
|
|
$ renderInfoListsAt (2*hw - 400) 0 cfig w
|
|
$ mapMaybe (crDisplayInfo cfig w) $ IM.elems $ _creatures w
|
|
where
|
|
hw = halfWidth cfig
|
|
|
|
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)
|
|
|
|
viewClipBounds :: Configuration -> World -> Picture
|
|
viewClipBounds cfig w
|
|
| _debug_view_clip_bounds cfig == AllRoomClipBoundaries
|
|
= setLayer DebugLayer $ color green $ concatMap (polygonWire . _cpPoints) (_roomClipping w)
|
|
| _debug_view_clip_bounds cfig == IntersectingRoomClipBoundaries
|
|
= setLayer DebugLayer $ f (_roomClipping w)
|
|
| otherwise = []
|
|
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 ^? wlDraw == 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
|