module Dodge.LightSources 
    ( tLightTimedIntensity
    , tLight
    , lightAt
    , colorLightAt
    , lampPic
    , lampCover
    , lampCoverWhen
    , doubleLampCover
    , verticalLampCover
    , chain
    )
    where
import Dodge.Data
import Geometry.Data
import Picture
import ShapePicture
import Shape
import Geometry

import Control.Lens

colorLightAt :: Point3 -> Point3 -> Int -> LightSource
colorLightAt col pos i = 
    LS {_lsID = i
       ,_lsPos = pos
       ,_lsDir = 0
       ,_lsRad = 700
       ,_lsIntensity = col
       ,_lsPict = lightSourcePicture
       }
lightSourcePicture :: LightSource -> Picture
lightSourcePicture ls = setLayer 1 . translate3 (_lsPos ls) . color col $ circleSolid 3
  where
    col = V4 r g b 1
    V3 r g b = _lsIntensity ls

lightAt :: Point3 -> Int -> LightSource
lightAt = colorLightAt 0.75

tLightTimedIntensity :: Int -> Float -> (Int -> Float) -> Point2 -> TempLightSource
tLightTimedIntensity t rmax intensityF (V2 x y) = TLS 
    { _tlsPos = V3 x y 0
    , _tlsRad = rmax
    , _tlsIntensity = f $ intensityF t
    , _tlsUpdate = upF
    , _tlsTime = t
    }
  where
    upF _ tls 
        | _tlsTime tls <= 0 = Nothing
        | otherwise         = Just $ tls    
            & tlsTime -~ 1
            & tlsIntensity .~ f (intensityF (_tlsTime tls) )
    f x' = V3 x' x' x'

tLight
    :: Int 
    -> Float -- ^ maximal radius
    -> Point3
    -> Point3 
    -> TempLightSource
tLight t rmax col (V3 x y z) = TLS 
    { _tlsPos = V3 x y z
    , _tlsRad = rmax
    , _tlsIntensity = col
    , _tlsUpdate = upF
    , _tlsTime = t
    }
  where
    upF _ tls 
        | _tlsTime tls <= 0 = Nothing
        | otherwise         = Just $ tls    
            & tlsTime -~ 1

lampPic :: Float -> Picture
--{-# INLINE lampPic #-}
lampPic h = setLayer 1 (setDepth h . color white $ circleSolid 3)

lampCover :: Float -> Prop
lampCover h = ShapeProp
    { _pjPos = V2 0 0
    , _pjID  = 0
    , _pjRot = 0
    , _pjUpdate = rotateProp 0.15
    , _prDraw = drawLampCover h
    , _prToggle = True
    }
lampCoverWhen :: (World -> Bool) -> Float -> Prop
lampCoverWhen cond h = ShapeProp
    { _pjPos = V2 0 0
    , _pjID  = 0
    , _pjRot = 0
    , _pjUpdate = setToggle cond `chain` rotateProp 0.15
    , _prDraw = drawLampCover h
    , _prToggle = True
    }

doubleLampCover :: Float -> Prop
doubleLampCover h = ShapeProp
    { _pjPos = V2 0 0
    , _pjID  = 0
    , _pjRot = 0
    , _pjUpdate = rotateProp 0.15
    , _prDraw = drawDoubleLampCover h
    , _prToggle = True
    }

-- on the current (27/9/21) version of shadow stencilling, this glitches
-- slightly when the shadow rotates towards the screen
verticalLampCover :: Float -> Prop
verticalLampCover h = ShapeProp
    { _pjPos = V2 0 0
    , _pjID  = 0
    , _pjRot = 0
    , _pjUpdate = rotateProp 0.15
    , _prDraw = drawVerticalLampCover h
    , _prToggle = True
    }

rotateProp :: Float -> Prop -> World -> World
rotateProp rotAmount pr w = w
    & props . ix (_pjID pr) . pjRot +~ rotAmount

setToggle :: (World -> Bool) -> Prop -> World -> World
setToggle cond pr w = w & props . ix (_pjID pr) . prToggle .~ cond w

-- TODO check whether this is simply the reader monad, flipped
chain :: (a -> b -> b) -> (a -> b -> b) -> a -> b -> b
chain f g x = f x . g x

drawLampCover :: Float -> Prop -> SPic
drawLampCover h pr | not (_prToggle pr) = mempty
                   | otherwise =
    ( translateSHz (h-2.5) . uncurryV translateSHf pos 
        $ rotateSH a $ mconcat
        [ translateSHz 1 . upperPrismPoly 1 $ rectNSEW 3 2    3 (-1)
        , translateSHz 1 . upperPrismPoly 1 $ rectNSEW 3 (-1) 3 2
        , translateSHz 2 . upperPrismPoly 1 $ rectNSEW 3 2    3 (-1)
        , translateSHz 2 . upperPrismPoly 1 $ rectNSEW 3 (-1) 3 2
        --, translateSHz 2.5 . upperPrismPoly 1 $ [V2 5 5,V2 (-4) 5,V2 5 (-4)]
        , upperPrismPoly 1 [V2 2 2,V2 (-1) 2,V2 2 (-1)]
        ]
    , mempty
    )
  where
    a = _pjRot pr
    pos = _pjPos pr

drawDoubleLampCover :: Float -> Prop -> SPic
drawDoubleLampCover h pr =
    ( translateSHz (h-2.5) . uncurryV translateSHf pos 
        $ rotateSH a $ mconcat
        [ upperPrismPoly 5 $ rectNSEW 6 5       6 (-6)
        , upperPrismPoly 5 $ rectNSEW (-5) (-6) 6 (-6)
        , upperPrismPoly 1 [V2 0 (-1),V2 6 5,V2 (-6) 5]
        , upperPrismPoly 1 [V2 0   1 ,V2 (-6) (-5),V2 6 (-5)]
        ]
    , mempty
    )
  where
    a = _pjRot pr
    pos = _pjPos pr

drawVerticalLampCover :: Float -> Prop -> SPic
drawVerticalLampCover h pr =
    ( translateSHz h . uncurryV translateSHf pos 
        $ rotateSHx a $ mconcat
        [ 
        translateSHz (-3) . upperPrismPoly 1 $ rectNSEW 2 (-2) 5 (-5)
        ]
    , mempty
    )
  where
    a = _pjRot pr
    pos = _pjPos pr