115 lines
3.9 KiB
Haskell
115 lines
3.9 KiB
Haskell
module Dodge.Render.ShapePicture (
|
|
worldSPic,
|
|
) where
|
|
|
|
import Control.Lens
|
|
import Data.Foldable
|
|
import Data.Strict.Tuple
|
|
import Dodge.Creature.Picture
|
|
import Dodge.Data.Universe
|
|
import Dodge.Debug.Picture
|
|
import Dodge.Draw
|
|
import Dodge.RadarBlip
|
|
import Dodge.Render.Picture
|
|
import Geometry
|
|
import qualified IntMapHelp as IM
|
|
import NewInt
|
|
import Picture
|
|
import Shape
|
|
import ShapePicture
|
|
|
|
worldSPic :: Configuration -> Universe -> SPic
|
|
worldSPic cfig u =
|
|
(mempty :!: extraPics cfig u)
|
|
<> foldup propSPic (filtOn _prPos _props)
|
|
<> foldup drawProjectile (filtOn _pjPos _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 (_unNIntMap . _floorItems))
|
|
<> foldup btSPic (filtOn _btPos _buttons)
|
|
<> foldup (mcSPic (u ^. uvWorld . cWorld . lWorld)) (filtOn _mcPos _machines)
|
|
where
|
|
w = _uvWorld u
|
|
foldup = foldMap'
|
|
filtOn f g = IM.filter (pointIsClose . f) (g (_lWorld (_cWorld w)))
|
|
pointIsClose = cullPoint cfig w
|
|
|
|
drawCreature :: Creature -> SPic
|
|
drawCreature cr = uncurryV translateSPxy (_crPos cr) . rotateSP (_crDir cr) $
|
|
case cr ^. crType of
|
|
BarrelCrit{} -> barrelShape
|
|
LampCrit{_lampHeight = h} -> lampCrSPic h
|
|
_ -> basicCrPict cr
|
|
|
|
barrelShape :: SPic
|
|
barrelShape = noPic $ cylinderPoly Medium Important (map (addZ 20) ps) (map (addZ 0) ps)
|
|
where
|
|
ps = polyCirc 3 10
|
|
|
|
lampCrSPic :: Float -> SPic
|
|
lampCrSPic h =
|
|
colorSH blue (upperBox Small Typical h $ rectWH 5 5)
|
|
:!: setLayer BloomLayer (setDepth h . color white $ circleSolid 3)
|
|
|
|
shiftDraw :: (a -> Point2) -> (a -> Float) -> (a -> a -> SPic) -> a -> SPic
|
|
shiftDraw fpos fdir fdraw x =
|
|
uncurryV translateSPxy (fpos x)
|
|
. rotateSP (fdir x)
|
|
$ fdraw x x
|
|
|
|
shiftDraw' :: (a -> Point2) -> (a -> Float) -> (a -> SPic) -> a -> SPic
|
|
shiftDraw' fpos fdir fdraw x =
|
|
uncurryV translateSPxy (fpos x)
|
|
. rotateSP (fdir x)
|
|
$ fdraw x
|
|
|
|
cullPoint :: Configuration -> World -> Point2 -> Bool
|
|
cullPoint cfig w p
|
|
| debugOn Close_shape_culling cfig = pointInPolygon p (w ^. wCam . camBoundBox)
|
|
| otherwise = dist (w ^. wCam . camCenter) p < (w ^. wCam . camViewDistance)
|
|
|
|
extraPics :: Configuration -> Universe -> Picture
|
|
extraPics cfig u =
|
|
setLayer FixedCoordLayer (fixedCoordPictures u)
|
|
<> foldMap drawTractorBeam (_tractorBeams lw)
|
|
<> foldMap drawLinearShockwave (_linearShockwaves lw)
|
|
<> foldMap drawShockwave (_shockwaves lw)
|
|
<> foldMap drawTeslaArc (_teslaArcs lw)
|
|
<> foldMap drawRadarSweep (_radarSweeps lw)
|
|
<> foldMap drawFlame (_flames lw)
|
|
<> foldMap drawEnergyBall (_energyBalls lw)
|
|
<> foldMap drawSpark (_sparks lw)
|
|
<> foldMap drawBul (_bullets lw)
|
|
<> foldMap drawBlip (_radarBlips lw)
|
|
<> _flares lw
|
|
<> foldMap drawLightSource (_lightSources lw)
|
|
<> foldMap ppDraw (_pressPlates lw)
|
|
<> viewClipBounds cfig w
|
|
<> debugDraw cfig w
|
|
<> foldMap (`_debugPic` u) (_uvDebug u) -- debug messages are in fixed coord pics
|
|
where
|
|
w = u ^. uvWorld
|
|
lw = w ^. cWorld . lWorld
|
|
|
|
ppDraw :: PressPlate -> Picture
|
|
ppDraw c = uncurryV translate (_ppPos c) $ rotate (_ppRot c) (_ppPict c)
|
|
|
|
floorItemSPic :: FloorItem -> SPic
|
|
floorItemSPic flit =
|
|
uncurryV translateSPxy (_flItPos flit) $
|
|
rotateSP
|
|
(_flItRot flit)
|
|
(itemSPic $ _flIt flit)
|
|
|
|
btSPic :: Button -> SPic
|
|
btSPic bt =
|
|
uncurryV translateSPxy (_btPos bt) $
|
|
rotateSP (_btRot bt) (drawButton (_btPict bt) bt)
|
|
|
|
mcSPic :: LWorld -> Machine -> SPic
|
|
mcSPic lw mc =
|
|
uncurryV translateSPxy (_mcPos mc) $
|
|
rotateSP (_mcDir mc) (drawMachine lw mc)
|