Work on chasm rooms

src/Dodge/Room/Tutorial.hs

@@ -1,5 +1,6 @@
 module Dodge.Room.Tutorial where
 
+import Control.Monad
 import qualified Data.Set as S
 import ShortShow
 import Dodge.Data.MTRS
@@ -46,6 +47,7 @@ tutAnoTree = do
         [ tToBTree "TutStartRez" . return . cleatOnward <$> tutRezBox
         , corDoor
         , tutHub
+        , tutLight
         , tutDrop
         , return $ tToBTree "cor" $ return $ cleatOnward corridor
         ----        , AnTree $ pickupTut
@@ -103,6 +105,75 @@ tutDrop = do
         , makeTermLine "-------------------------------------------"
         ]
 
+cChasm :: State LayoutVars Room
+cChasm = do
+    x <- state $ randomR (150,300)
+    y <- state $ randomR (150,300)
+    roomRectAutoLinks x y
+        <&> rmLinks %~ setOutLinks (isCornerLink NorthWest)
+        <&> rmLinks %~ setInLinks (isCornerLink SouthWest)
+        <&> rmPmnts <>~ [sps0 $ PutChasm (rectNSWE (y-50) 50 0 (x-50))]
+
+lChasm :: State LayoutVars Room
+lChasm = do
+    x <- state $ randomR (150,300)
+    y <- state $ randomR (150,300)
+    roomRectAutoLinks x y
+        <&> rmLinks %~ setOutLinks (isCornerLink NorthWest)
+        <&> rmLinks %~ setInLinks (isCornerLink SouthEast)
+        <&> rmPmnts <>~ [sps0 $ PutChasm (rectNSWE (y-50) 0 0 (x-50))]
+
+zChasm :: Float -> State LayoutVars Room
+zChasm z = do
+    x <- state $ randomR (150,300)
+    y <- state $ randomR (150,300)
+    roomRectAutoLinks x y
+        <&> rmLinks %~ setOutLinks (isCornerLink NorthWest)
+        <&> rmLinks %~ setInLinks (isCornerLink SouthEast)
+        <&> rmPmnts <>~ 
+                [sps0 $ PutChasm (rectNSWE (y/2-z) 0 0 (x-50))
+                ,sps0 $ PutChasm (rectNSWE y (y/2+z) 50 x)
+                ]
+
+midChasm :: State LayoutVars Room
+midChasm = do
+    x <- state $ randomR (200,300)
+    y <- state $ randomR (200,300)
+    r <- roomRectAutoLinks x y
+    cs <- join $ takeOne [cenoct x y,censquare x y]
+    shuffleLinks $ r
+        & rmLinks %~ setOutLinks (isMidEdgeLink r North)
+        & rmLinks %~ setInLinks (isMidEdgeLink r South)
+        & rmPmnts <>~ cs
+  where
+    censquare x y = do
+        z <- state $ randomR (40,60)
+        return [sps0 $ PutChasm (rectNSWE (y-z) z z (x-z))]
+    cenoct x y = return 
+        [sps0 $ PutChasm $ (V2 (x/2) (y/2) +) <$> polyOrthDist 8 (min x y/2 - 25)]
+--    dia x y = [sps0 $ PutChasm [V2 ]
+
+polyChasm :: Int -> Float -> State LayoutVars Room
+polyChasm n x = roomNgon n x
+
+chasmSimpleMaze :: State LayoutVars Room
+chasmSimpleMaze = join $ takeOne 
+        [midChasm
+        ,zChasm 25
+        ,lChasm
+        ,cChasm
+        ]
+
+tutLight :: State LayoutVars (MetaTree Room String)
+tutLight = do
+--    x <- roomRectAutoLinks 200 400
+--    let y = x & rmLinks %~ setOutLinks (\rl -> OnEdge North `S.member` _rlType rl)
+--              -- & rmLinks %~ setInLinks (\rl -> OnEdge South `S.member` _rlType rl)
+--             -- & rmLinks %~ setLinkType InLink (isCornerLink SouthEast)
+--              & rmLinks %~ setLinkType InLink (isMidEdgeLink x South)
+    x <- chasmSimpleMaze
+    return $ tToBTree "TutLight" $ treePost [x,cleatOnward corridor]
+
 tutHub :: State LayoutVars (MetaTree Room String)
 tutHub = do
     (is,wbp) <- setTreeInts =<< critsRoom 2