141 lines
4.5 KiB
Haskell
141 lines
4.5 KiB
Haskell
module Dodge.Render.ShapePicture
|
|
( worldSPic
|
|
)
|
|
where
|
|
import Dodge.Config.Data
|
|
--import Dodge.Debug.Picture
|
|
import Dodge.Picture.SizeInvariant
|
|
import Dodge.Data
|
|
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.Zone
|
|
import Geometry
|
|
import ShapePicture
|
|
import Shape
|
|
import Picture
|
|
import Sound.Data
|
|
|
|
import qualified Data.IntMap.Strict as IM -- Lazy?
|
|
import qualified Data.Map.Strict as M
|
|
--import Control.Lens
|
|
--import Data.Maybe
|
|
|
|
worldSPic :: Configuration -> World -> SPic
|
|
worldSPic cfig w =
|
|
(extraShapes w, extraPics cfig w)
|
|
<> foldMap (dbArg _prDraw) (filtOn _pjPos _props)
|
|
<> foldMap ((($ w) . ($ cfig)) . dbArg _crPict) (filtOn _crPos _creatures)
|
|
<> foldMap floorItemSPic (filtOn _flItPos _floorItems)
|
|
<> foldMap btSPic (filtOn _btPos _buttons)
|
|
<> foldMap mcSPic (filtOn _mcPos _machines)
|
|
where
|
|
filtOn f g = IM.filter (pointIsClose . f) (g w)
|
|
pointIsClose p = dist camCen p < winSize
|
|
winSize = 30 + max (_windowX cfig) (_windowY cfig)
|
|
camCen = _cameraCenter w
|
|
|
|
extraShapes :: World -> Shape
|
|
extraShapes = _foregroundShape
|
|
|
|
extraPics :: Configuration -> World -> Picture
|
|
extraPics cfig w = pictures (_decorations w)
|
|
<> concatMapPic (dbArg _ptDraw) (_particles w)
|
|
<> concatMapPic (dbArg _lsPict) (_lightSources w)
|
|
<> testPic w
|
|
<> concatMapPic clDraw (_clouds w )
|
|
<> concatMapPic ppDraw (_pressPlates w )
|
|
<> soundPics cfig w
|
|
<> viewBoundaries cfig w
|
|
<> drawPathing cfig w
|
|
|
|
-- TODO remove duplicate!
|
|
testPic :: World -> Picture
|
|
testPic _ = []
|
|
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)
|
|
|
|
soundPics :: Configuration -> World -> Picture
|
|
soundPics cfig w
|
|
| _show_sound cfig = pictures $ M.map (soundPic cfig w) $ _playingSounds w
|
|
| otherwise = []
|
|
|
|
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)
|
|
|
|
drawPathing :: Configuration -> World -> Picture
|
|
drawPathing cfig w
|
|
| _debug_pathing cfig
|
|
= -- setLayer 5 $
|
|
(color green . pictures . map (flip thickLine 5 . tflat2) $ graphToEdges gr)
|
|
<> concatMap dispInc (graphToIncidence gr)
|
|
| otherwise = []
|
|
where
|
|
dispInc (p,n) = setDepth 2 . uncurryV translate p . scale 0.1 0.1 $ text $ show n
|
|
gr = _pathGraph w
|
|
viewBoundaries :: Configuration -> World -> Picture
|
|
viewBoundaries cfig w
|
|
| _debug_view_boundaries cfig
|
|
= setLayer 5 $ color green (concatMap (polygonWire . _grBound) grs)
|
|
<> color yellow (concatMap (\q -> line [p,q]) $ farWallPoints p w)
|
|
| otherwise = []
|
|
where
|
|
p = _crPos $ you w
|
|
grs = filter (pointInOrOnPolygon p . _grBound) (_gameRooms w)
|
|
|
|
--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
|