Move toward indexed external placements

src/Dodge/Floor.hs

@@ -33,8 +33,8 @@ initialAnoTree :: RandomGen g => Tree [Annotation g]
 initialAnoTree = padSucWithCorridors $ treeFromTrunk 
     [[StartRoom]
     ,[ChainAnos 
-        [[SetLabel 0 $ return $ roomRectAutoLinks 100 100 
+        [[SetLabel 0 $ return $ roomRectAutoLinks 200 200 
-                    & rmExtPmnt ?~ externalButton red 
+                    & rmExtPmnt ?~ triggerSwitch red 
                         (anyLnkInPS 5 & psLnkRoomEff .~ (putWireStart 0 . extractRoomPos) )
                     & rmLinkEff .~ [putWireEnd 0]
          ]

src/Dodge/Layout.hs

@@ -14,9 +14,13 @@ import Dodge.Bounds
 import Dodge.Default.Wall
 import Dodge.Room.Link
 import Geometry
+import Geometry.ConvexPoly
 import qualified IntMapHelp as IM
 import Tile
 import Dodge.RandomHelp
+import Color
+import Shape
+--import Padding
 
 import Data.List (nubBy)
 import Data.Traversable
@@ -62,11 +66,22 @@ placeRoomWires rm w = IM.foldr ($) w
     $ IM.intersectionWith (placeWire rm) (_rmStartWires rm) (_rmEndWires rm)
 
 placeWire :: Room -> RoomWire -> RoomWire -> World -> World
-placeWire rm (RoomWire p' _) (RoomWire q' _) w = w & foregroundShape %~ (thinHighBar 80 p q <>)
+placeWire rm (RoomWire p _) (RoomWire q _) = foregroundShape 
+    %~ ((col $ thinHighBarChain 80 $ map (shiftPointBy rs) doOrdering) <>)
   where
+    --TODO use rmWalls for non convex rooms
+    --rmWalls = foldr cutWalls [] (_rmPolys rm)
+    doOrdering = orderPolygonAround rmcen (p:q:ps)
+    col | clockwise = colorSH red
+        | otherwise = colorSH orange
+    rmps = concat $ _rmPolys rm
+    rmcen = centroid rmps
+    clockwise = isLHS rmcen p q
+    ps  | clockwise = filter leftprightq rmps
+        | otherwise = filter rightpleftq rmps
+    leftprightq x = isLHS rmcen p x && isRHS rmcen q x
+    rightpleftq x = isRHS rmcen p x && isLHS rmcen q x
     rs = _rmShift rm
-    p = shiftPointBy rs p'
-    q = shiftPointBy rs q'
 
 doPartialPlacements :: ( (IM.IntMap [Placement],World) , [Room] ) -> (World,[Room])
 doPartialPlacements ((im,w),rms) = mapAccumR (doPartialPlacement im) w rms

src/Dodge/Layout/Tree/Shift.hs

@@ -26,33 +26,31 @@ posRms :: [ConvexPoly]
     -> [Tree RoomInt]
     -> Seq (Tree RoomInt)
     -> IO (Maybe [Room])
-posRms _ _ [] Empty = return $ Just []
+posRms bounds (parent,_) [] st = case st of
-posRms bounds (rtoadd,_) [] (Node (r,i) ts :<| tseq) 
+    Empty -> return $ Just []
-    = fmap (finalLinksUpdate rtoadd:) <$> posRms bounds (r,i) ts tseq
+    Node childi ts :<| tseq 
-posRms bounds (parent,i) (t@(Node (_,i') _):ts) tseq = do
+        -> fmap (finalLinksUpdate parent:) <$> posRms bounds childi ts tseq
+posRms bounds parenti (t@(Node (_,i') _):ts) tseq = do
     putStr $ "Trying to place room " ++ show i' ++ ": "
-    --tryLinks (0::Int) (_rmLinks $ doRoomShift parent)
+    tryLinks 0 (_rmLinks parent)
-    tryLinks (0::Int) (_rmLinks parent)
   where
-    tryLinks _ [] = do
+    parent = fst parenti
-        putStrLn "all links tried"
+    tryLinks _ [] = putStrLn "all links tried" >> return Nothing
-        return Nothing
     tryLinks j (l:ls) 
         | clipping  = tryLinks (j+1) ls
         | otherwise = do
             putStrLn $ "placing at link " ++ show j
-            mayrs <- posRms (convexBounds ++ bounds) newr ts (tseq |> shiftedt')
+            mayrs <- posRms (convexBounds ++ bounds) (first upr parenti) ts (tseq |> shiftedt)
             case mayrs of
-                Nothing -> do putStr ("Backtracking to room " ++ show i' ++ ": ") >> tryLinks (j+1) ls
+                Nothing -> putStr ("Backtracking to room " ++ show i' ++ ": ") >> tryLinks (j+1) ls
                 Just rs -> return (Just rs)
       where
         convexBounds = map pointsToPoly $ _rmBound r'
         clipping = or (convexPolysOverlap <$> convexBounds <*> bounds)
-        newr = (lnkEff l $ parent & rmLinks %~ delete l & rmPos %~ (uncurry (OutLink j) l :)
+        upr rm = lnkEff l $ rm & rmLinks %~ delete l & rmPos %~ (uncurry (OutLink j) l :)
-            , i)
         l' = shiftLinkBy (_rmShift parent) l
-        (Node (r',_) _) = applyToRoot (first $ shiftRoomToLink l') t
+        r' = doRoomShift . fst $ rootLabel shiftedt
-        shiftedt' = applyToRoot (first $ shiftRoomShiftToLink l') t
+        shiftedt = applyToRoot (first $ shiftRoomShiftToLink l') t
 
 lnkEff :: (Point2,Float) -> Room -> Room
 lnkEff x rm = case _rmLinkEff rm of

src/Dodge/LevelGen/Data.hs

@@ -163,7 +163,7 @@ jps0 pst = Just . Placement (PS (V2 0 0) 0) pst Nothing . intPlPlPl
 
 jps0PushPS :: PSType -> (Int -> Maybe Placement) -> Maybe Placement
 jps0PushPS pst f = Just . Placement (PS (V2 0 0) 0) pst Nothing
-    $ \plmnt -> (f (fromJust $ _plMID plmnt) <&> plSpot .~ _plSpot plmnt)
+    $ \plmnt -> f (fromJust $ _plMID plmnt) <&> plSpot .~ _plSpot plmnt
 
 ps0j :: PSType -> Placement -> Placement
 ps0j pst plmnt = Placement (PS (V2 0 0) 0) pst Nothing (const $ Just plmnt)

src/Dodge/Placements/Button.hs

@@ -1,5 +1,4 @@
-module Dodge.Placements.Button
+module Dodge.Placements.Button where
-    where
 import Dodge.Data
 import Color
 import Geometry
@@ -12,8 +11,8 @@ import Dodge.Placements.LightSource
 import Data.Maybe
 import Control.Lens
 
-externalButton :: Color -> PlacementSpot -> Placement
+triggerSwitch :: Color -> PlacementSpot -> Placement
-externalButton col ps = plCont ps (PutTrigger (const False))
+triggerSwitch col ps = plCont ps (PutTrigger (const False))
     $ \tp -> Just $ pContID ps (PutButton (makeSwitch col col (oneff $ trigid tp) (offeff $ trigid tp))) 
                     (const Nothing)
   where

src/Dodge/Room/Foreground.hs

@@ -47,8 +47,11 @@ diagonalLinesRect pa pb w d ang = zip lhsPoints $ map findDiPoint lhsPoints
 thinHighBar :: Float -> Point2 -> Point2 -> Shape
 thinHighBar = highBar 3
 
+thinHighBarLoop :: Float -> [Point2] -> Shape
+thinHighBarLoop h = foldMap (uncurry $ thinHighBar h) . loopPairs
+
 thinHighBarChain :: Float -> [Point2] -> Shape
-thinHighBarChain h = foldMap (uncurry $ thinHighBar h) . loopPairs
+thinHighBarChain h = foldMap (uncurry $ thinHighBar h) . chainPairs
 
 thickHighBar :: Float -> Point2 -> Point2 -> Shape
 thickHighBar = highBar 5

src/Dodge/Room/Start.hs

@@ -16,7 +16,7 @@ import Data.Tree
 import Control.Monad.State
 import Control.Lens
 import System.Random
-import qualified Data.IntMap.Strict as IM
+--import qualified Data.IntMap.Strict as IM
 
 rezBox :: Room
 rezBox = shiftRoomBy (V2 (-20) (-10),0) $ roomRect 40 20 1 1 
@@ -38,8 +38,6 @@ startRoom = do
             ]
     treeFromPost [Left rezBox, Left door] . Right 
         <$> randomiseOutLinks 
-            ((shiftRoomBy (V2 (-20) (-20),0) 
+            (shiftRoomBy (V2 (-20) (-20),0) 
-            $ roomRectAutoLinks w h & rmPmnts %~ (plmnts ++) 
+            ( roomRectAutoLinks w h & rmPmnts %~ (plmnts ++) 
-                & rmStartWires .~ IM.fromList [(0,RoomWire (V2   0   0) 0)]
-                & rmEndWires   .~ IM.fromList [(0,RoomWire (V2 500 500) 0)]
             ) & rmShift .~ (0,0) )

src/Geometry.hs

@@ -22,6 +22,7 @@ import Geometry.Intersect
 import Geometry.Bezier
 import Geometry.Vector
 import Geometry.LHS
+import Geometry.ConvexPoly
 
 import Data.Maybe
 import Data.List
@@ -132,7 +133,8 @@ orderAroundFirst (a:as) = a : orderPolygonAround a as
 -- | Reorder points to be anticlockwise around their center.
 orderPolygon :: [Point2] -> [Point2]
 orderPolygon [] = []
-orderPolygon ps = orderPolygonAround (1/ fromIntegral (length ps) *.* foldr1 (+.+) ps) ps
+--orderPolygon ps = orderPolygonAround (1/ fromIntegral (length ps) *.* foldr1 (+.+) ps) ps
+orderPolygon ps = orderPolygonAround (centroid ps) ps
 -- | Adds a point to a convex polygon.
 -- If the point is inside, returns the original.
 -- Points ordered anticlockwise, input not checked.
@@ -447,6 +449,13 @@ arcStepwisePositive ssize a cen v = (cen +.+) . (`rotateV` v) <$> rots
     n :: Int
     n = ceiling (a * magV v / ssize)
 
+-- | Given a list of points, returns pairs of points linking the points into a
+-- loop.
+chainPairs :: [Point2] -> [(Point2,Point2)]
+chainPairs [] = error "tried to make chain with empty list of points"
+chainPairs [_] = error "tried to make chain with singleton list of points"
+chainPairs xs = zip xs $ tail xs
+
 -- | Given a list of points, returns pairs of points linking the points into a
 -- loop.
 loopPairs :: [Point2] -> [(Point2,Point2)]

src/Padding.hs

@@ -6,6 +6,7 @@ module Padding
     , midPadL
     , rotU
     , rotD
+    , rotListAt
     )
     where
 leftPad :: Int -> a -> [a] -> [a]
@@ -37,3 +38,11 @@ rotD :: [a] -> [a]
 {-# INLINE rotD #-}
 rotD [] = []
 rotD xs = last xs : init xs
+
+rotListAt :: Eq a => a -> [a] -> [a]
+rotListAt x' xs = f x' xs []
+  where
+    f x (y:ys) zs
+        | y == x    = y:ys ++ zs
+        | otherwise = f x ys (y:zs)
+    f _ [] zs = zs