loop/src/Dodge/Placement/Instance/LightSource.hs

module Dodge.Placement.Instance.LightSource (
    mntLSOn,
    mntLSCond,
    aShape,
    aBar,
    lShape,
    jShape,
    liShape,
    mntLightLnkCond,
    mntLS,
    vShape,
    iShape,
    putLamp,
    spanColLightBlackI,
    spanLightI,
    spanLightY,
    mntLightLnkCond',
    spanLS,
    mntLightLnkShape,
) where

import Color
import Control.Lens
import Dodge.Creature.Inanimate
import Dodge.Data.GenWorld
import Dodge.LevelGen.PlacementHelper
import Dodge.LightSource
import Dodge.Room.Foreground
import Geometry
import RandomHelp
import Shape
import Linear

-- | mount a light source on a shape
mntLSOn ::
    -- | function describing the mount shape
    (Point2 -> Point3 -> Shape) ->
    -- | describing a possible color override for the shape
    LightSource ->
    Point2 ->
    Point3 ->
    (Placement -> Maybe Placement) ->
    Placement
mntLSOn shapeF ls wallp lsp@(V3 lx ly _) =
    ps0jPushPS (PutLabel "light") .
    ps0jPushPS (putShape $ shapeF wallp lsp)
    --ps0j (PutLabel "light") .
    --ps0j (putShape . setCol $ shapeF wallp lsp)
        . pt0 (PutLS $ ls & lsParam . lsPos .~ lsp')
  where
    lsp' = lsp -.-.- V3 x y 1
    -- hack! perturb the light position
    V2 x y = rotateV 1 . (0.1 *.*) . normalizeV $ wallp -.- V2 lx ly
--    setCol = maybe id colorSH mcol

iShape :: Point2 -> Point3 -> Shape
iShape wp (V3 x y z) = thinHighBar z wp (V2 x y)

lShape :: Point2 -> Point3 -> Shape
lShape wp (V3 x y z) =
    thinHighBar z wallposUp turnpos
        <> thinHighBar z turnpos (V2 x y)
  where
    n = vNormal (wp -.- V2 x y)
    wallposUp = wp +.+ n
    turnpos = V2 x y +.+ n

aBar :: Float -> [Point2] -> Shape
aBar h ps = foldMap (uncurry $ thinHighBar (h+0.1)) $ zip ps $ tail ps

jShape :: Point2 -> Point3 -> Shape
jShape wallpos (V3 x y z) =
    thinHighBar z wallposUp turn1
        <> thinHighBar z turn1 turn2
        <> thinHighBar z turn2 endpos
  where
    n = vNormal (wallpos -.- V2 x y)
    wallposUp = wallpos +.+ n
    turnpos = V2 x y +.+ n
    endpos = V2 x y
    turn1 = 0.5 *.* (wallposUp +.+ turnpos)
    turn2 = 0.5 *.* (turnpos +.+ endpos)

liShape :: Point2 -> Point3 -> Shape
liShape wallpos (V3 x y z) =
    thinHighBar z wallposUp turnpos
        <> thinHighBar z turnpos (V2 x y)
  where
    n = vNormal (V2 x y -.- wallpos)
    wallposUp = wallpos +.+ n
    turnpos = V2 x y +.+ n

aShape :: Point2 -> Point3 -> Shape
aShape wallpos (V3 x y z) = girder (z + 2) 20 10 pout wallpos
  where
    pout = V2 x y -.- 2 *.* squashNormalizeV (V2 x y -.- wallpos)

vShape :: Point2 -> Point3 -> Shape
vShape wallpos (V3 x y z) =
    thinHighBar z wallposUp lxy
        <> thinHighBar z wallposDown lxy
  where
    lxy = V2 x y
    n = vNormal (wallpos -.- lxy)
    wallposUp = wallpos +.+ n
    wallposDown = wallpos -.- n

mntLS :: (Point2 -> Point3 -> Shape) -> Point2 -> Point3 -> Placement
mntLS shp wallp lampp = mntLSOn shp defaultLS wallp lampp (const Nothing)
  where
    defaultLS = LS 0 $ LSParam 0 300 0.6

--mntLSCol :: (Point2 -> Point3 -> Shape) -> Color -> Point2 -> Point3 -> Placement
--mntLSCol shp col wallp lampp = mntLSOn shp (Just col) defaultLS wallp lampp (const Nothing)
--  where
--    defaultLS = LS 0 $ LSParam 0 200 0.6

--mntLSLampCol :: (Point2 -> Point3 -> Shape) -> Color -> Point2 -> Point3 -> Placement
--mntLSLampCol shp (V4 x y z _) wallp lampp =
--    mntLSOn
--        shp
--        Nothing
--        (defaultLS & lsParam . lsCol .~ col)
--        wallp
--        lampp
--        (const Nothing)
--  where
--    col = V3 x y z
--    defaultLS = LS 0 $ LSParam 0 200 0.6

mntLSCond ::
    (Point2 -> Point3 -> Shape) ->
    --    -> (RoomPos -> Room -> Maybe (PlacementSpot,RoomPos))
    PlacementSpot ->
    Placement
mntLSCond shp ps =
    -- updatePSToLevel 1 (const $ PSLnk shift (const id) Nothing) $
    mntLS shp 0 (V3 0 (-20) 95)
        & plSpot .~ ps

-- note that this perhaps pushes the vshape light out too far

--mntLight :: RandomGen g => Point2 -> Point2 -> State g Placement
--mntLight a b = do
--    shp <- takeOne [vShape, iShape, lShape, jShape, liShape]
--    return $ mntLS shp a (addZ 90 b)

mntLightLnkCond :: RandomGen g => PlacementSpot -> State g Placement
mntLightLnkCond ps = do
    shp <- takeOne [vShape, lShape, jShape, liShape]
    return $ mntLSCond (fmap (fmap $ colorSH black) shp) ps

mntLightLnkShape :: (Point2 -> Point3 -> Shape) -> PlacementSpot -> Placement
mntLightLnkShape shp = mntLSCond (fmap (fmap $ colorSH black) shp)

mntLightLnkCond' :: PlacementSpot -> Placement
mntLightLnkCond' = mntLSCond (fmap (fmap $ colorSH black) vShape)

--spanLSLightI :: LightSource -> Float -> Point2 -> Point2 -> Placement
--spanLSLightI ls h a b =
--    ps0j (PutLS $ ls & lsParam . lsPos .~ V3 x y h) $
--        sps0 $ putShape $ thinHighBar h a b
--  where
--    V2 x y = 0.5 *.* (a +.+ b)

spanLS :: LightSource -> Point2 -> Point2 -> Placement
spanLS ls a b =
    Placement (PS (V2 x y) 0) (PutLS ls) Nothing Nothing $
        const $ const $ Just $ sps0 $ putShape $ thinHighBar h a b
  where
    V3 _ _ h = _lsPos (_lsParam ls) + 5
    V2 x y = 0.5 *.* (a +.+ b)

spanColLightI :: Point3 -> Float -> Point2 -> Point2 -> Placement
spanColLightI col h a b =
    ps0j (PutLS $ lsColPos col (V3 x y (h -5))) $
        sps0 $ putShape $ thinHighBar h a b
  where
    V2 x y = 0.5 *.* (a +.+ b)

spanColLightBlackI :: Point3 -> Float -> Point2 -> Point2 -> Placement
spanColLightBlackI col h a b =
    ps0j (PutLS $ lsColPos col (V3 x y (h -5))) $
        sps0 $ putShape $ colorSH black $ thinHighBar h a b
  where
    V2 x y = 0.5 *.* (a +.+ b)

spanLightI :: Point2 -> Point2 -> Placement
--spanLightI = spanColLightI 0.75 50.1
spanLightI = spanColLightI 0.75 95

spanLightY :: Point2 -> Point2 -> Point2 -> Point2 -> Placement
spanLightY l x y z = 
    ps0j (PutLS $ lsColPos 0.75 (addZ (h -5) l)) $
        ps0j (f x) $
        ps0j (f y) $
        sps0 $ f z
  where
    f p = putShape $ thinHighBar h p (l + normalize (l-p))
    h = 95

--extendAway :: Point2 -> Point2 -> Point2
--extendAway p x = p +.+ squashNormalizeV (p -.- x)

--putColorLamp :: Point3 -> PSType
--putColorLamp col = PutCrit (colorLamp col 90)

putLamp :: PSType
putLamp = PutCrit (lamp 50)