loop/src/Dodge/Render/ShapePicture.hs

module Dodge.Render.ShapePicture (
    worldSPic,
) where

import Dodge.Render.List
import Control.Lens
import Control.Monad (guard)
import Data.Foldable
import Data.Maybe
import Dodge.Base
import Dodge.Creature.Picture
import Dodge.Data.Universe
import Dodge.Debug.Picture
import Dodge.Draw
import Dodge.Flare
import Dodge.RadarBlip
import Dodge.Render.Picture
import Geometry
import qualified IntMapHelp as IM
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 _floorItems)
        <> foldup btSPic (filtOn _btPos _buttons)
        <> foldup mcSPic (filtOn _mcPos _machines)
        <> aimDelaySweep w
        <> anyTargeting cfig w
  where
    w = _uvWorld u
    foldup = foldMap'
    filtOn f g = IM.filter (pointIsClose . f) (g (_lWorld (_cWorld w)))
    pointIsClose = cullPoint cfig w

aimDelaySweep :: World -> SPic
aimDelaySweep w = fromMaybe mempty $ do
    cr <- w ^? cWorld . lWorld . creatures . ix 0
    aimstatus <- cr ^? crStance . posture
    guard (aimstatus == Aiming)
    return $ noShape $ drawSweep cr w

drawSweep :: Creature -> World -> Picture
drawSweep cr w = fromMaybe mempty $ do
    a <- safeArgV (mwp -.- p)
    let a'
            | a - cdir > pi = cdir + 2 * pi
            | a - cdir < - pi = cdir - 2 * pi
            | otherwise = cdir
    return $
        setLayer FixedCoordLayer $
            uncurryV translate (worldPosToScreen campos p) $
                arcFull (a - rot) 10 white (a' - rot) 1 white (5 + dist mwp p * campos ^. camZoom) white
  where
    cdir = _crDir cr
    rot = campos ^. camRot
    p = _crPos cr
    campos = w ^. wCam
    theinput = w ^. input
    mwp = mouseWorldPos theinput campos

anyTargeting :: Configuration -> World -> SPic
anyTargeting cfig w = fromMaybe mempty $ do
    tt <- cr ^? crTargeting . ctType . _Just
    return $ noShape $ drawTargeting tt cr cfig w
  where
    cr = you w

drawCreature :: Creature -> SPic
drawCreature cr = case _crType cr of
    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 =
    fold (_decorations lw)
        <> 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)
        <> foldMap drawFlare (_flares lw)
        <> foldMap (dbArg (drawBeam . _bmDraw)) (_positronBeams $ _beams lw)
        <> foldMap (dbArg (drawBeam . _bmDraw)) (_electronBeams $ _beams lw)
        <> foldMap (dbArg (drawLightSource . _lsPict)) (_lightSources lw)
        <> testPic cfig w
        <> 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

testPic :: Configuration -> World -> Picture
testPic _ _ = mempty

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 :: Machine -> SPic
mcSPic mc =
    uncurryV translateSPxy (_mcPos mc) $
        rotateSP (_mcDir mc) (drawMachine mc)