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

module Dodge.Room.Modify.Girder (
    addGirderLights,
    addGirderFrom,
    addHighGirder,
    addHighGirder',
    addGirderEW,
    addGirderNS,
    addGirderNS',
) where

import Color
import Data.List (nub)
import Data.Maybe
import qualified Data.Set as S
import Dodge.Data.GenWorld
import Dodge.LevelGen.PlacementHelper
import Dodge.LightSource
import Dodge.PlacementSpot
import Dodge.Room.Foreground
import Geometry
import LensHelp
import RandomHelp
import Shape

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 (FromEdge West i))
                        (isUnusedLnkType (FromEdge West i))
                        $ \ps1 ps2 -> sps0 $ putShape $ colorSH col $ shapef (_psPos ps1) (_psPos ps2)
                    | i <- girderPosOrder
                    ]
                )

addGirderFrom :: CardinalPoint -> Int -> (Point2 -> Point2 -> Shape) -> Color -> Room -> Room
addGirderFrom cp fromi shapef col =
    rmPmnts
        .:~ foldr1
            setFallback
            [ sps0 PutNothing
            , twoRoomPoss rmposcond rmposcond $
                \ps1 ps2 -> sps0 $ putShape $ colorSH col $ shapef (_psPos ps1) (_psPos ps2)
            ]
  where
    rmposcond = isUnusedLnkType (FromEdge cp fromi)

-- | 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 (FromEdge West i))
                        (isUnusedLnkType (FromEdge West 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 (FromEdge South i))
                        (isUnusedLnkType (FromEdge South 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 (FromEdge East) nslnks
        ewgirds = girdson (FromEdge North) 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]
        ]

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 (FromEdge East) nslnks
        ewgirds = girdson (FromEdge North) 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 <- [0 .. numlnks - 1]
        ]

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

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 $
                                girderV'
                                    96
                                    20
                                    10
                                    (V2 (midw - 10) (hiToFloat rm hi))
                                    (V2 0 (hiToFloat rm hi))
                    x
                        | x > 0 ->
                            Just $
                                girderV'
                                    96
                                    20
                                    10
                                    (V2 (midw + 10) (hiToFloat rm hi))
                                    (V2 w (hiToFloat rm hi))
                    _ -> Nothing
                )
                extragirderpos
    return $
        rm & rmPmnts
            .++~ ( sps0 (PutForeground $ girderV' 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 . PutForeground) extragirders