loop/src/Dodge/Room/Modify/Girder.hs

module Dodge.Room.Modify.Girder 
    ( addGirderLights
    , addGirderFrom
    , addHighGirder
    , addGirderEW
    , addGirderNS
    , addGirderNS'
    , addGirderFromWest
    ) where
--import Dodge.Data
import Dodge.LevelGen.Data
import Dodge.Data
--import Dodge.Room.Procedural
import Dodge.Room.Foreground
--import Dodge.Room.RoadBlock
--import Dodge.Placement.Instance
--import Dodge.Placement.TopDecoration
import Dodge.PlacementSpot
import Dodge.LightSource
--import Padding
import Color
import Shape
import LensHelp
import Geometry
import RandomHelp

import Data.Maybe
import Data.List (nub)
import qualified Data.Set as S

addGirderNS :: RandomGen g => (Point2 -> Point2 -> Shape) -> Color -> Room -> State g Room
addGirderNS shapef col room = do
    let nwestlnks = length $ filter ((OnEdge North `S.member`) . _rlType) $ _rmLinks room
    girderPosOrder <- shuffle [1 .. nwestlnks - 2]
    return $ room & rmPmnts .:~ foldr1 setFallback 
        (sps0 PutNothing : [ twoRoomPoss 
            (isUnusedLnkType (FromWest i)) 
            (isUnusedLnkType (FromWest i)) 
            $ \ps1 ps2 -> sps0 $ PutShape $ colorSH col $ shapef (_psPos ps1) (_psPos ps2) 
       | i <- girderPosOrder]
        )
-- this can be cleaned up
addGirderFromWest :: RandomGen g => Int -> (Point2 -> Point2 -> Shape) -> Color -> Room -> State g Room
addGirderFromWest fromwesti shapef col room = do
    let nwestlnks = length $ filter ((OnEdge North `S.member`) . _rlType) $ _rmLinks room
    girderPosOrder <- shuffle [0 .. nwestlnks - 1]
    return $ room & rmPmnts .:~ foldr1 setFallback 
        (sps0 PutNothing : [ twoRoomPoss 
            (isUnusedLnkType (FromWest i)) 
            (isUnusedLnkType (FromWest i)) 
            $ \ps1 ps2 -> sps0 $ PutShape $ colorSH col $ shapef (_psPos ps1) (_psPos ps2) 
       | i <- [fromwesti]]
        )

addGirderFrom :: RandomGen g => CardinalPoint -> Int 
    -> (Point2 -> Point2 -> Shape) -> Color -> Room -> State g Room
addGirderFrom cp fromwesti shapef col room = do
    let nwestlnks = length $ filter ((OnEdge North `S.member`) . _rlType) $ _rmLinks room
    girderPosOrder <- shuffle [0 .. nwestlnks - 1]
    return $ room & rmPmnts .:~ foldr1 setFallback 
        (sps0 PutNothing : [ twoRoomPoss 
            (isUnusedLnkType (FromWest i)) 
            (isUnusedLnkType (FromWest i)) 
            $ \ps1 ps2 -> sps0 $ PutShape $ colorSH col $ shapef (_psPos ps1) (_psPos ps2) 
       | i <- [fromwesti]]
        )
-- | Allows girder to be on edge
addGirderNS' :: RandomGen g => (Point2 -> Point2 -> Shape) -> Color -> Room -> State g Room
addGirderNS' shapef col room = do
    let nwestlnks = length $ filter ((OnEdge North `S.member`) . _rlType) $ _rmLinks room
    girderPosOrder <- shuffle [0 .. nwestlnks - 1]
    return $ room & rmPmnts .:~ foldr1 setFallback 
        (sps0 PutNothing : [ twoRoomPoss 
            (isUnusedLnkType (FromWest i)) 
            (isUnusedLnkType (FromWest i)) 
            $ \ps1 ps2 -> sps0 $ PutShape $ colorSH col $ shapef (_psPos ps1) (_psPos ps2) 
       | i <- girderPosOrder]
        )
addGirderEW :: RandomGen g => (Point2 -> Point2 -> Shape) -> Color -> Room -> State g Room
addGirderEW shapef col room = do
    let nwestlnks = length $ filter ((OnEdge West `S.member`) . _rlType) $ _rmLinks room
    girderPosOrder <- shuffle [1 .. nwestlnks - 2]
    return $ room & rmPmnts .:~ foldr1 setFallback 
        (sps0 PutNothing :
        [ twoRoomPoss
            (isUnusedLnkType (FromSouth i)) 
            (isUnusedLnkType (FromSouth i)) 
            $ \ps1 ps2 -> sps0 $ PutShape $ colorSH col $ shapef (_psPos ps1) (_psPos ps2) 
       | i <- girderPosOrder]
        )

-- TODO add a central light to this, with mounted light fallback?
addGirder :: RandomGen g => (Point2 -> Point2 -> Shape) -> Color -> Room -> State g Room
addGirder shapef col room = do
    let nslnks = length $ filter ((OnEdge North `S.member`) . _rlType) $ _rmLinks room
        ewlnks = length $ filter ((OnEdge East `S.member`) . _rlType) $ _rmLinks room
        nsgirds = girdson FromEast nslnks
        ewgirds = girdson FromNorth ewlnks
    girders <- shuffle $ nsgirds ++ ewgirds
    return $ room & rmPmnts .:~ foldr1 setFallback 
        (sps0 PutNothing : girders)
  where
    girdson f numlnks = [ twoRoomPoss
            (isUnusedLnkType (f i))
            (isUnusedLnkType (f i))
            $ \ps1 ps2 -> sps0 $ PutShape $ colorSH col $ shapef (_psPos ps1) (_psPos ps2) 
            | i <- [1 .. numlnks - 2] ]

addHighGirder :: RandomGen g => Room -> State g Room
addHighGirder r = do
    gsize <- takeOne [(20,10),(30,10),(40,10),(30,15)]
    hgshape <- takeOne $ map (\f -> uncurry (f 96) gsize)
            [girder, girderZ, girderV]
    addGirder hgshape black r

randomLightPositions :: RandomGen g => Room -> State g [(Int,Int)]
randomLightPositions rm = do
    let rmtype = _rmType rm
    xs <- shuffle [0.._numLinkEW rmtype]
    ys <- shuffle [0.._numLinkNS rmtype]
    let n = max (length xs) (length ys)
    return $ take n $ zip (xs ++ xs) (ys ++ ys)

intsToPos :: Room -> (Int,Int) -> Point2
intsToPos rm (x,y) = V2
    (20 + _linkGapEW rmtype * fromIntegral x)
    (20 + _linkGapNS rmtype * fromIntegral y)
  where
    rmtype = _rmType rm

wiToFloat :: Room -> Int -> Float
wiToFloat rm wi = 20 + _linkGapEW (_rmType rm) * fromIntegral wi

hiToFloat :: Room -> Int -> Float
hiToFloat rm hi = 20 + _linkGapNS (_rmType rm) * fromIntegral hi

addGirderLights :: RandomGen g => Room -> State g Room
addGirderLights rm = do
    lpis <- randomLightPositions rm
    let rmtype = _rmType rm
        lps = map (intsToPos rm) lpis
        midi = _numLinkEW rmtype `div` 2
        w = _rmWidth rmtype
        h = _rmHeight rmtype
        midw = wiToFloat rm midi
        extragirderpos = nub $ map (\(wi,hi) -> (wi - midi, hi)) lpis
        extragirders = mapMaybe (\(i,hi) -> case i of
            x | x < 0 -> Just $ girderVCapL 20 96 20 10 (V2 (midw - 10) (hiToFloat rm hi)) 
                                                (V2 0 (hiToFloat rm hi))
            x | x > 0 -> Just $ girderVCapL 20 96 20 10 (V2 (midw + 10) (hiToFloat rm hi)) 
                                                (V2 w (hiToFloat rm hi))
            _ -> Nothing
            ) extragirderpos
    return $ rm & rmPmnts .++~ 
        (sps0 (PutShape $ colorSH black $ girderVCapLR 20 96 20 10 (V2 midw 0) (V2 midw h))
        : map (\p -> sps (PS p 0) (PutLS $ lsColPos 0.75 (V3 0 0 90))) lps
        ) ++ map (sps0 . PutShape . colorSH black) extragirders