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

module Dodge.Placement.Instance.LightSource where
import Dodge.Data
import Dodge.LightSource
import Dodge.LevelGen.Data
import Dodge.Room.Foreground
import Geometry
--import Geometry.Vector3D
import Dodge.Creature.Inanimate
import Shape.Data
import Dodge.Default
import RandomHelp
import Color
import Shape
import ShapePicture

import Control.Lens
import Data.Maybe

propLSThen :: (Prop -> World -> World)
    -> (Prop -> World -> LightSource -> LightSource)
    -> LightSource 
    -> Prop
    -> (Placement -> Placement -> Maybe Placement) -- ^ continuation, access to ls and prop placements
    -> Placement
propLSThen propf lsf ls prop cont = pt0 (PutLS ls)
    $ \lspl -> Just $ pt0 (PutProp $ prop & pjUpdate .~ theupdate (fromJust $ _plMID lspl))
    $ cont lspl
  where
    theupdate lsid pr w = propf pr w & lightSources . ix lsid %~ lsf pr w

moveLSThen :: (World -> (Point2,Float))
    -> Point3   -- ^ light source offset
    -> Shape
    -> (Placement -> Placement -> Maybe Placement)
    -> Placement
moveLSThen posf off sh = propLSThen propupdate lsupdate thels theprop
  where
    propupdate pr w = w 
        & props . ix (_pjID pr) . prPos .~ fst (posf w)
        & props . ix (_pjID pr) . pjRot .~ snd (posf w)
    lsupdate _ w = lsParam . lsPos .~ addZ 0 (fst (posf w)) +.+.+ rotate3z (snd (posf w)) off
    thels = defaultLS
    theprop = ShapeProp
        { _prPos = 0
        , _pjID = 0
        , _pjRot = 0
        , _pjUpdate = const id
        , _prDraw = \pr -> noPic $ uncurryV translateSHf (_prPos pr) $ rotateSH (_pjRot pr) sh
        , _prToggle = True
        }
    
-- | mount a light source on a shape
mntLSOn
    :: (Point2 -> Point3 -> Shape) -- ^ function describing the mount shape
    -> Maybe Color  -- ^ describing a possible color override for the shape
    -> LightSource -> Point2 -> Point3 -> (Placement -> Maybe Placement) -> Placement
mntLSOn shapeF mcol ls wallp lsp@(V3 lx ly _)
    = ps0jPushPS (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

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 Nothing defaultLS wallp lampp (const Nothing)

mntLSCol :: (Point2 -> Point3 -> Shape) -> Color -> Point2 -> Point3 -> Placement
mntLSCol shp col wallp lampp = mntLSOn shp (Just col) defaultLS wallp lampp (const Nothing)

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

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 :: Point2 -> Point2 -> Placement
mntLight a b = RandomPlacement $ do
    shp <- takeOne [vShape,iShape,lShape,jShape,liShape]
    return $ mntLS shp a (addZ 90 b)

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

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 10 (PS (V2 x y) 0) (PutLS ls) 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

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 90)