137 lines
4.6 KiB
Haskell
137 lines
4.6 KiB
Haskell
module Dodge.Render.ShapePicture (
|
|
worldSPic,
|
|
) where
|
|
|
|
import Control.Lens
|
|
import Data.Foldable
|
|
import Data.Strict.Tuple
|
|
import Dodge.Base
|
|
import Dodge.Creature.Picture
|
|
import Dodge.Data.Universe
|
|
import Dodge.Debug.Picture
|
|
import Dodge.Draw
|
|
import Dodge.RadarBlip
|
|
import Dodge.Render.List
|
|
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 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 (_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 = case _crType cr of
|
|
Avatar {} -> basicCrPict cr
|
|
Humanoid{} -> basicCrPict cr
|
|
Barreloid{} ->
|
|
picAtCrPos1
|
|
( setDepth 20 $
|
|
fold
|
|
[ color orange $ circleSolid 10
|
|
, setDepth 0.049 . color (greyN 0.5) $ circleSolid 8
|
|
, color (greyN 0.5) $ circleSolid 8
|
|
]
|
|
)
|
|
cr
|
|
Lampoid{_lampHeight = h} -> uncurryV translateSPxy (_crPos cr) $ lampCrSPic h
|
|
NonDrawnCreature -> mempty
|
|
|
|
lampCrSPic :: Float -> SPic
|
|
lampCrSPic h =
|
|
colorSH blue (upperBox Small Typical h $ rectWH 5 5)
|
|
:!: setLayer BloomLayer (setDepth h . color white $ circleSolid 3)
|
|
|
|
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 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 drawLaser (_lasersToDraw 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)
|
|
<> setLayer
|
|
FixedCoordLayer
|
|
( toTopLeft cfig . translate (1.3 * halfWidth cfig) 0
|
|
. drawList
|
|
. take 50
|
|
. drop (u ^. uvDebugMessageOffset)
|
|
. map text
|
|
$ foldMap (`_debugMessage` u) (_uvDebug u)
|
|
)
|
|
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)
|
|
|