Add file

src/Dodge/Room/Modify.hs

@@ -0,0 +1,4 @@
+module Dodge.Room.Modify 
+    ( module Dodge.Room.Modify.Girder
+    ) where
+import Dodge.Room.Modify.Girder

src/Dodge/Room/Modify/Girder.hs

@@ -0,0 +1,121 @@
+module Dodge.Room.Modify.Girder 
+    ( addGirderLights
+    , addHighGirder
+    , addGirderEW
+    , addGirderNS
+    ) where
+--import Dodge.Data
+import Dodge.LevelGen.Data
+import Dodge.RandomHelp
+--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 Data.Maybe
+import Data.List (nub)
+--import Data.Tree
+import Control.Monad.State
+import System.Random
+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]
+        )
+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 $ zip
+        (take n $ xs ++ xs)
+        (take n $ 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 (PutShape $ colorSH black $ 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 . PutShape . colorSH black) extragirders