142 lines
4.8 KiB
Haskell
142 lines
4.8 KiB
Haskell
--{-# LANGUAGE LambdaCase #-}
|
|
module Dodge.Render.ShapePicture (worldSPic) where
|
|
|
|
import Dodge.Debug
|
|
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.Item.Draw.SPic
|
|
import Dodge.RadarBlip
|
|
import Dodge.Render.Picture
|
|
import Geometry
|
|
import qualified IntMapHelp as IM
|
|
import Linear.V3
|
|
import Picture
|
|
import Shape
|
|
import ShapePicture
|
|
|
|
worldSPic :: Config -> Universe -> SPic
|
|
worldSPic cfig u =
|
|
(mempty :!: extraPics cfig u)
|
|
<> foldup propSPic (filtOn _prPos _props)
|
|
<> foldMap' debrisSPic (filtOn' (xyV3 . _dbPos) _debris)
|
|
<> foldup drawProjectile (filtOn (^. pjPos . _xy) _projectiles)
|
|
<> foldup drawPulseBall (filtOn _pbPos _pulseBalls)
|
|
-- <> foldup (shiftDraw _blPos _blDir (const $ drawBlock . _blDraw))
|
|
<> foldup (shiftDraw _blPos _blDir (const $ noPic . _blDraw))
|
|
(filtOn _blPos _blocks)
|
|
<> foldMap' (shiftDraw _fsPos _fsDir (const _fsSPic)) (filtOn' _fsPos _foreShapes)
|
|
<> foldup (drawCreature (lw ^. items)) (filtOn (^. crPos . _xy) _creatures)
|
|
<> foldup
|
|
(Prelude.uncurry floorItemSPic)
|
|
( IM.intersectionWith
|
|
(,)
|
|
(lw ^. items)
|
|
(filtOn _flItPos _floorItems)
|
|
)
|
|
<> foldup btSPic (filtOn _btPos _buttons)
|
|
<> foldup (mcSPic (w ^. cWorld)) (filtOn _mcPos _machines)
|
|
<> foldMap' drawChasm (w ^. cWorld . chasms)
|
|
<> w ^. cWorld . lWorld . tempSPic
|
|
where
|
|
w = u ^. uvWorld
|
|
lw = w ^. cWorld . lWorld
|
|
foldup = foldMap'
|
|
filtOn f g = IM.filter (pointIsClose . f) (g lw)
|
|
filtOn' f g = filter (pointIsClose . f) (g lw)
|
|
pointIsClose = cullPoint cfig w
|
|
|
|
drawChasm :: [Point2] -> SPic
|
|
drawChasm = foldMap (Prelude.uncurry drawCliff) . loopPairs
|
|
|
|
drawCliff :: Point2 -> Point2 -> SPic
|
|
drawCliff x y =
|
|
noPic
|
|
. translateSHz (-500.01)
|
|
. colorSH (dark orange)
|
|
$ upperPrismPoly Large Important 500
|
|
[x, 0.5 * (x + y) + normalizeV (vNormal (y - x)), y]
|
|
|
|
drawPulseBall :: PulseBall -> SPic
|
|
drawPulseBall pb =
|
|
translateSPz 20
|
|
. uncurryV translateSPxy (pb ^. pbPos)
|
|
. noShape
|
|
. setLayer BloomLayer
|
|
$ circleSolidCol green white 10
|
|
|
|
drawCreature :: IM.IntMap Item -> Creature -> SPic
|
|
drawCreature m cr = translateSP (_crPos cr) . rotateSP (_crDir cr) $
|
|
case cr ^. crType of
|
|
_ | CrIsCorpse sp <- cr ^. crHP -> sp
|
|
_ | null (cr ^? crHP . _HP) -> mempty
|
|
BarrelCrit{} -> barrelShape
|
|
LampCrit{_lampHeight = h} -> lampCrSPic h
|
|
_ -> basicCrPict m 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
|
|
|
|
cullPoint :: Config -> World -> Point2 -> Bool
|
|
cullPoint cfig w p
|
|
| debugOn Close_shape_culling cfig = pointInPoly p (w ^. wCam . camBoundBox)
|
|
| otherwise = dist (w ^. wCam . camCenter) p < (w ^. wCam . camViewDistance)
|
|
|
|
extraPics :: Config -> 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 drawBullet (_bullets lw)
|
|
<> foldMap drawBlip (_radarBlips lw)
|
|
<> _flares lw
|
|
<> foldMap drawLightSource (_lightSources lw)
|
|
<> viewClipBounds cfig w
|
|
<> foldMap (drawDebug u) (u ^. uvConfig . debug_booleans)
|
|
where
|
|
w = u ^. uvWorld
|
|
lw = w ^. cWorld . lWorld
|
|
|
|
floorItemSPic :: Item -> FloorItem -> SPic
|
|
floorItemSPic itm flit =
|
|
uncurryV translateSPxy (_flItPos flit) $
|
|
rotateSP
|
|
(_flItRot flit)
|
|
(itemSPic itm)
|
|
|
|
btSPic :: Button -> SPic
|
|
btSPic bt = uncurryV translateSPxy (_btPos bt) $ rotateSP (_btRot bt) (drawButton bt)
|
|
|
|
mcSPic :: CWorld -> Machine -> SPic
|
|
mcSPic cw mc = uncurryV translateSPxy (_mcPos mc) $ rotateSP (_mcDir mc) (drawMachine cw mc)
|
|
|
|
drawBullet :: Bullet -> Picture
|
|
drawBullet pt =
|
|
setLayer BloomLayer
|
|
. setDepth 20
|
|
. color (V4 200 200 200 2)
|
|
$ thickLine 2 [_buOldPos pt, _buPos pt]
|