Work on rooms

src/Dodge/BaseTriggerType.hs

@@ -21,7 +21,8 @@ itemTriggerType loc
 baseItemTriggerType :: Item -> TriggerType
 baseItemTriggerType itm = case itm ^. itType of
     HELD hit -> heldTriggerType hit
-    ATTACH CAPACITOR -> AutoTrigger 10
+    ATTACH CAPACITOR -> AutoTrigger 0
+--    ATTACH CAPACITOR -> AutoTrigger 10
     _ -> NoTrigger
 
 heldTriggerType :: HeldItemType -> TriggerType
@@ -54,8 +55,7 @@ heldTriggerType = \case
     FLAMETORRENT -> NoTrigger
     FLAMEWALL -> NoTrigger
     BLOWTORCH -> NoTrigger
-    SPARKGUN -> NoTrigger
+    TESLACOIL -> NoTrigger
-    TESLAGUN -> NoTrigger
     TRACTORGUN -> NoTrigger
     RLAUNCHER -> SemiAutoTrigger 20
     RLAUNCHERX{} -> SemiAutoTrigger 20

src/Dodge/Block/Debris.hs

@@ -1,20 +1,20 @@
 module Dodge.Block.Debris (
     cubeShape,
---    dirtColor,
+    --    dirtColor,
     makeDoorDebris,
     makeBlockDebris,
     makeDebris,
     makeDebrisDirected,
 ) where
 
-import Dodge.Material.Color
-import qualified Data.IntMap.Strict as IM
-import Dodge.ShiftPoint
 import Data.Foldable
+import qualified Data.IntMap.Strict as IM
 import qualified Data.IntSet as IS
 import Data.Maybe
 import Dodge.Data.World
+import Dodge.Material.Color
 import Dodge.Material.Sound
+import Dodge.ShiftPoint
 import Dodge.WorldEvent.Sound
 import Geometry
 import Grid
@@ -30,7 +30,7 @@ makeDoorDebris dr w = w & makeDebris mt p
     p = centroid . fmap fst $ (dr ^. drFootPrint) & each . each %~ shiftPointBy p2a
     mt = fromMaybe Stone $ do
         wlids <- w ^? cWorld . lWorld . doors . ix (_drID dr) . drFootPrint
-        ((wlid,_),_) <- IM.minViewWithKey wlids 
+        ((wlid, _), _) <- IM.minViewWithKey wlids
         w ^? cWorld . lWorld . walls . ix wlid . wlMaterial
 
 makeBlockDebris :: Block -> World -> World
@@ -44,33 +44,39 @@ makeBlockDebris bl w = foldl' (flip $ makeDebris mt) w ps
         wl <- w ^? cWorld . lWorld . walls . ix wlid
         return $ _wlMaterial wl
 
---makeDebris :: Material -> Color -> Point2 -> World -> World
+-- makeDebris :: Material -> Color -> Point2 -> World -> World
 makeDebris :: Material -> Point2 -> World -> World
 makeDebris = makeDebrisDirected (2 * pi) 0
 
 makeDebrisDirected :: Float -> Float -> Material -> Point2 -> World -> World
---makeDebrisDirected :: Float -> Float -> Material -> Color -> Point2 -> World -> World
+-- makeDebrisDirected :: Float -> Float -> Material -> Color -> Point2 -> World -> World
---makeDebrisDirected arcrad dir bm col p w =
+-- makeDebrisDirected arcrad dir bm col p w =
 makeDebrisDirected arcrad dir bm p w =
     w
---        & flip (foldl' (flip $ plNew (cWorld . lWorld . props) prID)) thedebris
+        --        & flip (foldl' (flip $ plNew (cWorld . lWorld . props) prID)) thedebris
-        & cWorld . lWorld . debris <>~ thedebris
+        & cWorld
-        & randGen .~ newg
+        . lWorld
+        . debris
+        <>~ thedebris
+        & randGen
+        .~ newg
         & soundOriginsIDsAt [MaterialSound bm i | i <- [0, 1, 2]] (destroyMatS bm) p
   where
     (thedebris, newg) = mapM f [35, 55, 75, 95] & runState $ _randGen w
     f h = do
         v <- rotateV (dir - arcrad / 2) <$> randInArcStrip 1 2 arcrad
         spinspeed <- randomR (-0.2, -0.1) & state
---        basedebris <- baseDebris bm
+        --        basedebris <- baseDebris bm
-        return $ DebrisChunk
+        return $
+            DebrisChunk
                 { _dbPos = p `v2z` h
---            , _dbType = BlockDebris col
+                , --            , _dbType = BlockDebris col
-            , _dbType = BlockDebris (materialColor bm)
+                  _dbType = BlockDebris (materialColor bm)
                 , _dbVel = v `v2z` 0
                 , _dbRot = Q.qID
                 , _dbSpin = Q.axisAngle (vNormal v `v2z` 0) spinspeed
                 }
+
 --            basedebris
 --                & prColor .~ col
 --                & prPos .~ p
@@ -91,9 +97,13 @@ debrisSize mt = case mt of
     Electronics -> 10
     Flesh -> 10
     ForceField -> 10
+    Photovoltaic -> 10
+    LightningRod -> 10
+    Pyroelectric -> 10
+    Piezoelectric -> 10
 
---shardShape :: Float -> Shape
+-- shardShape :: Float -> Shape
---shardShape size =
+-- shardShape size =
 --    translateSHz (- size) $
 --        upperPrismPolySU
 --            size
@@ -102,10 +112,10 @@ debrisSize mt = case mt of
 --            , V2 (- size) (-1)
 --            ]
 --
---jaggedShape :: State StdGen Shape
+-- jaggedShape :: State StdGen Shape
---jaggedShape = do
+-- jaggedShape = do
 --    s <- randomR (4, 10) & state
 --    return $ shardShape s
 
 cubeShape :: Float -> Shape
-cubeShape size = translateSHz (- size) $ upperPrismPolySU (2 * size) $ square size
+cubeShape size = translateSHz (-size) $ upperPrismPolySU (2 * size) $ square size

src/Dodge/Combine/Combinations.hs

@@ -92,8 +92,7 @@ itemCombinations =
 --           , po [HELD LASGUN, HELD LASGUN, cr HARDWARE] dualBeam
 --           , po [HELD LASGUN, cr TRANSFORMER] (lasWide 2)
 --           , po [HELD LASGUN, HELD LASGUN, HELD LASGUN, cr HARDWARE] lasCircle
-           , p [o $ cr TRANSFORMER, p 2 $ cr CAN] sparkGun
+           , p [o $ cr TRANSFORMER, p 2 $ cr CAN] teslaCoil
-           , p [o (HELD SPARKGUN), p 2 $ cr PIPE] teslaGun
 --           , p [o $ cr TELEPORTMODULE, p 2 $ cr MICROCHIP] blinker
            , p [o $ HELD BLINKER, p 2 $ cr MICROCHIP] unsafeBlinker
            , po [cr MAGNET, cr TIN] (magShield MagnetRepulse)

src/Dodge/Creature.hs

@@ -114,6 +114,7 @@ inventoryX c = case c of
         [introScan t | t <- [minBound..maxBound]] <>
         [ flameThrower
         , chemFuelPouch
+        , makeTypeCraft PUMP
         , fuelPack
         , copier ABSOLUTE
         , nulgate
@@ -344,7 +345,7 @@ stackedInventory =
     , megaBattery
     , capacitor
     , makeTypeCraft TRANSFORMER
-    , teslaGun
+    , teslaCoil
     , megaBattery
     , flameThrower
     , chemFuelPouch

src/Dodge/Creature/Impulse/UseItem.hs

@@ -53,6 +53,7 @@ useItemLoc cr loc pt w
         | LaserWeaponSF <- sf = True
         | HeldPlatformSF <- sf = True
         | PulseBallSF <- sf = True
+        | PlasmaSF <- sf = True
         | UnderBarrelPlatformSF <- sf = True
         | otherwise = False
     sf = loc ^. locDT . dtValue . _2

src/Dodge/Creature/Statistics.hs

@@ -106,8 +106,7 @@ heldItemWeight = \case
     FLAMETORRENT -> 10
     FLAMEWALL -> 10
     BLOWTORCH -> 10
-    SPARKGUN -> 15
+    TESLACOIL -> 15
-    TESLAGUN -> 15
     TRACTORGUN -> 10
     RLAUNCHER -> 20
     RLAUNCHERX{} -> 20

src/Dodge/Creature/YourControl.hs

@@ -220,8 +220,7 @@ heldItemBulkiness = \case
     FLAMETORRENT -> 1
     FLAMEWALL -> 1
     BLOWTORCH -> 1
-    SPARKGUN -> 1
+    TESLACOIL -> 1
-    TESLAGUN -> 1
     TRACTORGUN -> 1
     RLAUNCHER -> 0.9
     RLAUNCHERX{} -> 0.9

src/Dodge/Data/ComposedItem.hs

@@ -42,7 +42,9 @@ data ItemSF -- Structural Function
     | CapacitorSF
     | TransformerSF
     | PulseBallSF
+    | PlasmaSF
     | TorchSF
+    | PumpSF
     deriving (Eq, Ord, Show, Read)
 
 type CItem = (Item, ItemSF)

src/Dodge/Data/DoubleTree.hs

@@ -5,11 +5,6 @@
 module Dodge.Data.DoubleTree where
 
 import Control.Lens
---import Data.Aeson
---import Data.Aeson.TH
-import Data.Bifunctor
-
---import qualified Data.Map.Strict as M
 
 data DoubleTreeNodeType
     = DTRootNode
@@ -18,67 +13,15 @@ data DoubleTreeNodeType
     | DTMidBelowNode
     | DTBottomNode
 
--- for each child, records the link type to the father node
-data LabelDoubleTreeNodeType a
-    = LDTRootNode
-    | LDTTopNode a
-    | LDTMidAboveNode a
-    | LDTMidBelowNode a
-    | LDTBottomNode a
-
 data DTree a = DT {_dtValue :: a, _dtLeft :: [DTree a], _dtRight :: [DTree a]}
     deriving (Eq, Ord, Show, Read)
 
-data LDTree b a = LDT -- LabelDoubleTree
-    { _ldtValue :: a
-    , _ldtLeft :: [(b, LDTree b a)]
-    , _ldtRight :: [(b, LDTree b a)]
-    }
-    deriving (Eq, Ord, Show, Read)
-
--- I am not sure about the double use of records here
-data ContextLDT b a
-    = TopLDT
-    | LeftwardLDT
-        { _cldtUp :: ContextLDT b a
-        , _cldtCloseLeft :: [(b, LDTree b a)]
-        , _cldtParent :: a
-        , _cldtLink :: b
-        , _cldtCloseRight :: [(b, LDTree b a)]
-        , _cldtFarRight :: [(b, LDTree b a)]
-        }
-    | RightwardLDT
-        { _cldtUp :: ContextLDT b a
-        , _cldtFarLeft :: [(b, LDTree b a)]
-        , _cldtCloseLeft :: [(b, LDTree b a)]
-        , _cldtParent :: a
-        , _cldtLink :: b
-        , _cldtCloseRight :: [(b, LDTree b a)]
-        }
-
-data LocationLDT b a = LocLDT
-    { _locLdtContext :: ContextLDT b a
-    , _locLDT :: LDTree b a
-    }
-
 instance Functor DTree where
     fmap f (DT x l r) = DT (f x) (fmap (fmap f) l) (fmap (fmap f) r)
 
 instance Foldable DTree where
     foldMap f (DT x l r) = foldMap (foldMap f) l <> f x <> foldMap (foldMap f) r
 
-instance Functor (LDTree b) where
-    fmap f (LDT x l r) = LDT (f x) (fmap (second $ fmap f) l) (fmap (second $ fmap f) r)
-
-instance Bifunctor LDTree where
-    second = fmap
-    first f (LDT x l r) =
-        LDT
-            x
-            (map (bimap f (first f)) l)
-            (map (bimap f (first f)) r)
-
-
 data ContextDT a
     = TopDT
     | LeftwardDT
@@ -102,35 +45,12 @@ data LocationDT a = LocDT
     }
 
 makeLenses ''DTree
-makeLenses ''LDTree
-makeLenses ''LocationLDT
-makeLenses ''ContextLDT
 makeLenses ''LocationDT
 makeLenses ''ContextDT
 
-instance Functor (LocationLDT b) where
-    fmap f (LocLDT c t) = LocLDT (fmap f c) (fmap f t)
-
 instance Functor LocationDT where
     fmap f (LocDT c t) = LocDT (fmap f c) (fmap f t)
 
-instance Functor (ContextLDT b) where
-    fmap f = \case
-        TopLDT -> TopLDT
-        LeftwardLDT u cl p l cr fr -> LeftwardLDT 
-            (fmap f u)
-            (fmap (fmap (fmap f)) cl)
-            (f p)
-            l
-            (fmap (fmap (fmap f)) cr)
-            (fmap (fmap (fmap f)) fr)
-        RightwardLDT u fl cl p l cr -> RightwardLDT (fmap f u)
-            (fmap (fmap (fmap f)) fl)
-            (fmap (fmap (fmap f)) cl)
-            (f p)
-            l
-            (fmap (fmap (fmap f)) cr)
-
 instance Functor ContextDT where
     fmap f = \case
         TopDT -> TopDT

src/Dodge/Data/GenWorld.hs

@@ -24,7 +24,7 @@ import System.Random
 data GenWorld = GenWorld
     { _gwWorld :: World
     , _genRooms :: IM.IntMap Room
-    , _genPmnt :: IM.IntMap Placement
+    , _genPmnt :: IM.IntMap Placement  -- stored generated placements
     , _genInts :: IM.IntMap Int
     }
 
@@ -100,6 +100,8 @@ data PlacementSpot
     | PSNoShiftCont {_psPos :: Point2, _psRot :: Float}
     | PSPos
         { _psSelect :: RoomPos -> Room -> Maybe (PlacementSpot, RoomPos)
+        -- looks for the first rp for which a rp rm returns Just (ps,rp'),
+        -- replaces the rp with rp'
         , _psRoomEff :: RoomPos -> Room -> Room
         , _psFallback :: Maybe Placement
         }
@@ -138,7 +140,8 @@ data Room = Room
     , _rmPos :: [RoomPos]
     , _rmPath :: S.Set (Point2, Point2)
     , _rmPmnts :: [Placement]
-    , _rmInPmnt :: [(Int,GenWorld -> Placement)]
+    , _rmInPmnt :: [(Int,GenWorld -> State StdGen Placement)]  -- so far as I can tell,
+        -- the first Int only determines the order in which these are applied
     , _rmBound :: [[Point2]]
     , _rmFloor :: Floor
     , _rmName :: String
@@ -161,3 +164,12 @@ makeLenses ''RoomType
 makeLenses ''PSType
 makeLenses ''PlacementSpot
 makeLenses ''Placement
+
+-- I may regret this. I believe it satisfies associativity, but haven't thought
+-- about it too much.
+instance Semigroup Placement where
+    p <> q = p & plIDCont %~ f
+      where
+        f g gw pl = case g gw pl of
+            Nothing -> Just q
+            Just r -> Just $ r & plIDCont %~ f

src/Dodge/Data/Item/Combine.hs

@@ -100,6 +100,7 @@ data AttachType
     | HOMINGMODULE
     | SHELLPAYLOAD {_shellPayload :: Payload}
     | CAPACITOR
+    | COMPRESSOR
     deriving (Eq, Ord, Show, Read)
 
 data AmmoMagType
@@ -163,8 +164,7 @@ data HeldItemType
     | FLAMETORRENT
     | FLAMEWALL
     | BLOWTORCH
-    | SPARKGUN
+    | TESLACOIL
-    | TESLAGUN
     | TRACTORGUN
     | RLAUNCHER
     | RLAUNCHERX {_xNum :: Int}

src/Dodge/Data/Material.hs

@@ -17,6 +17,10 @@ data Material
     | Flesh
     | Electronics
     | ForceField
+    | Photovoltaic
+    | LightningRod
+    | Pyroelectric
+    | Piezoelectric
     deriving (Eq, Ord, Show, Bounded, Enum, Read) --Generic, Flat)
 
 deriveJSON defaultOptions ''Material

src/Dodge/Data/Muzzle.hs

@@ -40,6 +40,7 @@ data MuzzleEffect
     | MuzzleLaser
     | MuzzlePulseLaser
     | MuzzlePulseBall
+    | MuzzlePlasmaBall
     | MuzzleTesla
     | MuzzleTractor
     | MuzzleRLauncher

src/Dodge/Data/Room.hs

@@ -38,6 +38,10 @@ data RoomType
         , _rmWidth :: Float
         , _rmHeight :: Float
         }
+    | RoomNgon
+        { _rmngonSides :: Int 
+        , _rmngonSize :: Float
+        }
     deriving (Eq, Ord)
 
 data RoomLinkType
@@ -80,6 +84,8 @@ data PathFromEdge = PathFromEdge CardinalPoint Int
 data RoomPosFlag
     = RoomPosOnGrid {_onGridFromEdges :: S.Set PathFromEdge}
     | RoomPosOffGrid {_offGridFromEdges :: S.Set PathFromEdge}
+    | RoomPosOnFloor
+    | ColoredLightRP
     deriving (Eq, Ord, Show)
 
 data UsedPos

src/Dodge/Debug.hs

@@ -4,7 +4,6 @@ module Dodge.Debug (debugEvents, drawDebug) where
 
 import Geometry.Data
 import Dodge.Render.Label
-import Dodge.Data.DoubleTree
 import Dodge.HeldUse
 import Dodge.DoubleTree
 import Dodge.Item.Grammar
@@ -260,7 +259,7 @@ showMuzzlePositions  u = fold $ do
         ^? ix invid . _2
     return . color red $ setLayer DebugLayer $ reduceLocDT (f cr) loc
   where
-    f cr loc = foldMap (g . muzzlePos loc cr)  (itemMuzzles $ loc ^. locDT . dtValue . _1)
+    f cr loc = foldMap (g . muzzlePos loc cr)  (itemMuzzles $ loc)
       where
         g :: Point3Q -> Picture
         g pq = translate3 (pq ^. _1) $ crossPic 5

src/Dodge/DisplayInventory.hs

@@ -143,7 +143,7 @@ updateDisplaySections w cfig =
     (sfclose, sclose) =
         filterSectionsPair closefiltcurs plainRegex closeitms "NEARBY ITEMS" $
             w ^? hud . diCloseFilter . _Just
-    interfaceshead = if null btitems then mempty else makehead "NEARBY INTERFACES"
+    interfaceshead = if null btitems then mempty else makehead "INTERFACES"
     btitems =
         IM.fromDistinctAscList . zip [0 ..] $
             mapMaybe (closeButtonToSelectionItem w) (w ^. hud . closeButtons)

src/Dodge/DoubleTree.hs

@@ -1,40 +1,13 @@
-{-# LANGUAGE LambdaCase #-}
 module Dodge.DoubleTree where
 
 import Dodge.Data.DoubleTree
 import Control.Lens
-import Data.Bifunctor
 import qualified Data.IntMap.Strict as IM
 import Data.Monoid
 
 singleDT :: a -> DTree a
 singleDT x = DT x [] []
 
-singleLDT :: a -> LDTree b a
-singleLDT x = LDT x [] []
-
-ldtToDT :: LDTree b a -> DTree a
-ldtToDT (LDT x l r) = DT x (map (ldtToDT . snd) l) (map (ldtToDT . snd) r)
-
-locLDTToLocDT :: LocationLDT b a -> LocationDT a
-locLDTToLocDT (LocLDT con t) = LocDT (conLDTToConDT con) (ldtToDT t)
-
-conLDTToConDT :: ContextLDT b a -> ContextDT a
-conLDTToConDT = \case
-    TopLDT -> TopDT
-    LeftwardLDT u cl p _ cr fr -> LeftwardDT 
-        (conLDTToConDT u)
-        (map (ldtToDT . snd) cl)
-        p
-        (map (ldtToDT . snd) cr)
-        (map (ldtToDT . snd) fr)
-    RightwardLDT u fl cl p _ cr -> RightwardDT 
-        (conLDTToConDT u)
-        (map (ldtToDT . snd) fl)
-        (map (ldtToDT . snd) cl)
-        p
-        (map (ldtToDT . snd) cr)
-        
 dtStartPropagate :: (a -> c) -> (c -> a -> c) -> DTree a -> DTree c
 dtStartPropagate g f (DT x l r) = DT z 
     (fmap (dtPropagate' f z) l)
@@ -49,80 +22,6 @@ dtPropagate' f x (DT y l r) = DT z
   where
     z = f x y
 
-ldtStartPropagate :: (a -> c) -> (c -> b -> a -> c) -> LDTree b a -> LDTree b c
-ldtStartPropagate g f (LDT x l r) = LDT z 
-    (fmap (\(j,t) -> (j,ldtPropagate' z j f t)) l)
-    (fmap (\(j,t) -> (j,ldtPropagate' z j f t)) r)
-  where
-    z = g x
- 
-
-ldtPropagate' :: c -> b -> (c -> b -> a -> c) -> LDTree b a -> LDTree b c
-ldtPropagate' x i f (LDT y l r) = LDT z 
-    (fmap (\(j,t) -> (j,ldtPropagate' z j f t)) l)
-    (fmap (\(j,t) -> (j,ldtPropagate' z j f t)) r)
-  where
-    z = f x i y
-
--- propagate two functions down the links of an LDT tree
--- which function is chosen depends on whether it is a left or right branch
-ldtPropagate ::
-    (c -> b -> c) ->
-    (c -> b -> c) ->
-    c ->
-    LDTree b a ->
-    LDTree c a
-ldtPropagate lf rf = ildtPropagate (const lf) (const rf)
-
--- Propgates a value (of type c) down the branches of the LDT.
--- The value is updated according a "left" or "right" function (lf or rf),
--- that acts on the parent value, the link, and the child value.
--- For each node, the updated value is used to update a final value (of type d).
-ldtPropagateFold ::
-    (c -> a -> b -> a -> c) ->
-    (c -> a -> b -> a -> c) ->
-    (c -> a -> d -> d) ->
-    c ->
-    LDTree b a ->
-    d ->
-    d
-ldtPropagateFold lf rf up x (LDT v l r) =
-    alaf Endo foldMap (\(s, y) -> ldtPropagateFold lf rf up (rf x v s (_ldtValue y)) y) r
-        . alaf Endo foldMap (\(s, y) -> ldtPropagateFold lf rf up (lf x v s (_ldtValue y)) y) l
-        . up x v
-
--- Propgates a value (of type c) down the branches of the LDT.
--- The value is updated according a "left" or "right" function (lf or rf),
--- that acts on the parent value, the link, and the child value.
--- For each node-tree, the updated value is used to update a final value (of type d).
-ldtPropagateFoldTree ::
-    (c -> a -> b -> a -> c) ->
-    (c -> a -> b -> a -> c) ->
-    (c -> LDTree b a -> d -> d) ->
-    c ->
-    LDTree b a ->
-    d ->
-    d
-ldtPropagateFoldTree lf rf up x t@(LDT v l r) =
-    alaf Endo foldMap (\(s, y) -> ldtPropagateFoldTree lf rf up (rf x v s (_ldtValue y)) y) r
-        . alaf Endo foldMap (\(s, y) -> ldtPropagateFoldTree lf rf up (lf x v s (_ldtValue y)) y) l
-        . up x t
-
-ildtPropagate ::
-    (Int -> c -> b -> c) ->
-    (Int -> c -> b -> c) ->
-    c ->
-    LDTree b a ->
-    LDTree c a
-ildtPropagate lf rf x (LDT v l r) = LDT v (imap (go lf x) l) (imap (go rf x) r)
-  where
-    go f y i (z, t) = (f i y z, ildtPropagate lf rf (f i y z) t)
-
-ldtPropagateIndices :: LDTree b a -> LDTree b (a, [Either Int Int])
-ldtPropagateIndices (LDT x l r) = LDT (x, []) (imap (f Left) l) (imap (f Right) r)
-  where
-    f e i (y, t) = (y, second (e i :) <$> ldtPropagateIndices t)
-
 -- conceptually, in a tree growing from left to right,
 -- bottom -> top is equated with left -> right.
 -- this does not match with thinking of a list as top -> bottom, so take care
@@ -216,36 +115,6 @@ dtToAdjRootParentEither root par f (DT x l r) = do
   where
     g = f . _dtValue
 
-ldtToIM :: (a -> Int) -> LDTree b a -> IM.IntMap (LDTree b a)
-ldtToIM f t@(LDT x l r) = IM.insert (f x) t $ IM.unions $ map (ldtToIM f . snd) $ l <> r
-
-ldtToIndentList :: LDTree b a -> [(a, Int, LabelDoubleTreeNodeType b)]
-ldtToIndentList = ldtIL LDTRootNode
-
-ldtIL :: LabelDoubleTreeNodeType b -> LDTree b a -> [(a, Int, LabelDoubleTreeNodeType b)]
-ldtIL nt (LDT x l r) =
-    map
-        doindent
-        ( concat
-            ( headMap
-                (\(lab, c) -> ldtIL (LDTBottomNode lab) c)
-                (\(lab, c) -> ldtIL (LDTMidBelowNode lab) c)
-                l
-            )
-        )
-        ++ [(x, 0, nt)]
-        ++ map
-            doindent
-            ( concat
-                ( lastMap
-                    (\(lab, c) -> ldtIL (LDTTopNode lab) c)
-                    (\(lab, c) -> ldtIL (LDTMidAboveNode lab) c)
-                    r
-                )
-            )
-  where
-    doindent (a, b, c) = (a, b + 1, c)
-
 headMap :: (a -> b) -> (a -> b) -> [a] -> [b]
 headMap f g (x : xs) = f x : map g xs
 headMap _ _ [] = []
@@ -260,31 +129,6 @@ prettyDT f (DT x l r) =
     concatMap (map ('/' :) . prettyDT f) r
         ++ (f x : concatMap (map ('\\' :) . prettyDT f) l)
 
-prettyLDT :: (a -> String) -> LDTree b a -> [String]
-prettyLDT f (LDT x l r) =
-    concatMap (map ('/' :) . prettyLDT f . snd) r
-        ++ (f x : concatMap (map ('\\' :) . prettyLDT f . snd) l)
-
-ldtToLoc :: LDTree b a -> LocationLDT b a
-ldtToLoc = LocLDT TopLDT
-
--- should probably do tests for these
-locUp :: LocationLDT b a -> Maybe (LocationLDT b a)
-locUp (LocLDT TopLDT _) = Nothing
-locUp (LocLDT c@LeftwardLDT{} t) =
-    Just $
-        LocLDT
-            (_cldtUp c)
-            (LDT (_cldtParent c) (_cldtCloseLeft c ++ ((_cldtLink c, t) : _cldtCloseRight c)) (_cldtFarRight c))
-locUp (LocLDT c@RightwardLDT{} t) =
-    Just $
-        LocLDT
-            (_cldtUp c)
-            (LDT (_cldtParent c) (_cldtFarLeft c) (_cldtCloseLeft c ++ ((_cldtLink c, t) : _cldtCloseRight c)))
-
---locToTop :: LocationLDT b a -> LocationLDT b a
---locToTop loc = maybe loc locToTop $ locUp loc
-
 locUp' :: LocationDT a -> Maybe (LocationDT a)
 locUp' (LocDT TopDT _) = Nothing
 locUp' (LocDT c@LeftwardDT{} t) =
@@ -301,30 +145,12 @@ locUp' (LocDT c@RightwardDT{} t) =
 locToTop :: LocationDT a -> LocationDT a
 locToTop loc = maybe loc locToTop $ locUp' loc
 
---locToTop = fix $ \x -> fromMaybe x $ locUp x
-
-locLeftmost :: LocationLDT b a -> LocationLDT b a
-locLeftmost loc = maybe loc locLeftmost $ alaf First foldMap Just $ locGoLeft loc
-
-locRightmost :: LocationLDT b a -> LocationLDT b a
-locRightmost loc = maybe loc locRightmost $ alaf Last foldMap Just $ locGoRight loc
-
 locDTLeftmost :: LocationDT a -> LocationDT a
 locDTLeftmost loc = maybe loc locDTLeftmost $ alaf First foldMap Just $ locDTGoLeft loc
 
 locDTRightmost :: LocationDT a -> LocationDT a
 locDTRightmost loc = maybe loc locDTRightmost $ alaf Last foldMap Just $ locDTGoRight loc
 
--- should probably do tests for these
-locGoLeft :: LocationLDT b a -> [LocationLDT b a]
-locGoLeft (LocLDT c (LDT v l r)) =
-    [LocLDT (LeftwardLDT c closel v link closer r) t | (closel, (link, t), closer) <- locGoHelp id l]
-
--- should probably do tests for these
-locGoRight :: LocationLDT b a -> [LocationLDT b a]
-locGoRight (LocLDT c (LDT v l r)) =
-    [LocLDT (RightwardLDT c l closel v link closer) t | (closel, (link, t), closer) <- locGoHelp id r]
-
 -- should probably do tests for these
 locDTGoLeft :: LocationDT a -> [LocationDT a]
 locDTGoLeft (LocDT c (DT v l r)) =
@@ -351,56 +177,12 @@ locDTGoHelp f = go []
     go cleft (y : ys) = (cleft, f y, ys) : go (cleft <> [y]) ys
     go _ [] = []
 
--- Propgates a value (of type c) down the branches of the ContextLDT.
--- The value is updated according a "left" or "right" function (lf or rf),
--- that acts on the parent value, the link, and the child value.
--- For each context node, the updated value is used to update a final value (of type d).
-cldtPropagateFold ::
-    (c -> a -> b -> a -> c) ->
-    (c -> a -> b -> a -> c) ->
-    (c -> LocationLDT b a -> d -> d) ->
-    c ->
-    LocationLDT b a ->
-    d ->
-    d
-cldtPropagateFold lf rf up x loc =
-    alaf
-        Endo
-        foldMap
-        ( \(LocLDT con' t') ->
-            cldtPropagateFold
-                lf
-                rf
-                up
-                (lf x (_cldtParent con') (_cldtLink con') (_ldtValue t'))
-                (LocLDT con' t')
-        )
-        (locGoLeft loc)
-        . alaf
-            Endo
-            foldMap
-            ( \(LocLDT con' t') ->
-                cldtPropagateFold
-                    lf
-                    rf
-                    up
-                    (rf x (_cldtParent con') (_cldtLink con') (_ldtValue t'))
-                    (LocLDT con' t')
-            )
-            (locGoRight loc)
-        . up x loc
-
-reduceLocLDT :: Monoid m => (LocationLDT b a -> m) -> LocationLDT b a -> m
-reduceLocLDT f x =
-    foldMap (reduceLocLDT f) (locGoLeft x) <> f x
-        <> foldMap (reduceLocLDT f) (locGoRight x)
-
 reduceLocDT :: Monoid m => (LocationDT a -> m) -> LocationDT a -> m
 reduceLocDT f x =
     foldMap (reduceLocDT f) (locDTGoLeft x) <> f x
         <> foldMap (reduceLocDT f) (locDTGoRight x)
 
--- Propgates a value (of type c) down the branches of the ContextLDT.
+-- Propgates a value (of type c) down the branches of the ContextDT.
 -- The value is updated according a "left" or "right" function (lf or rf),
 -- that acts on the parent value and the child value.
 -- For each context node, the updated value is used to update a final value (of type d).

src/Dodge/Floor.hs

@@ -25,13 +25,13 @@ initialRoomTree =
     foldMTRS $
         intersperse
             (zoom lyGen doorCor)
-            [ intAnno startRoom
+            [ startRoom
             , passthroughLockKeyLists
                     [(sensorRoomRunPast ElectricSensor, takeOne 
                         [-- CRAFT (ENERGYBALLCRAFT TeslaBall) , 
-                        HELD SPARKGUN])]
+                        HELD TESLACOIL])]
                     itemRooms
-            , intAnno lasSensorTurretTest
+            , lasSensorTurretTest
             , --    , AnRoom $ tanksRoom [] [] <&> rmPmnts .~ []
               --    , AnRoom $ tanksRoom [] []
               --    , AnRoom $ roomCCrits 0
@@ -63,7 +63,7 @@ initialRoomTree =
                 $ tanksRoom [] [] >>= rToOnward "empty tanksRoom" . pure . cleatOnward
             , passthroughLockKeyLists lockRoomKeyItems itemRooms
             , randomChallenges
-            , intAnno lasSensorTurretTest
+            , lasSensorTurretTest
             , --    ,[AnTree $ fmap pure roomCCrits]
               --    ,[AirlockAno]
               --    ,[Corridor]

src/Dodge/HeldUse.hs

@@ -50,6 +50,7 @@ gadgetEffect :: Int -> LocationDT OItem -> Creature -> World -> World
 gadgetEffect pt loc
     | UseHeld{} <- loc ^. locDT . dtValue . _1 . itUse = heldEffect pt loc
     | PulseBallSF <- loc ^. locDT . dtValue . _2 = heldEffect pt loc
+    | PlasmaSF <- loc ^. locDT . dtValue . _2 = heldEffect pt loc
     | DROPPER x <- loc ^. locDT . dtValue . _1 . itType
       , Just i <- loc ^? locDT . dtValue . _1 . itUse . uInt
       , pt == 0 =
@@ -153,17 +154,24 @@ locMuzzles loc
             & ix 0 . mzFlareType .~ TeslaGunFlare
             & ix 0 . mzEffect .~ MuzzlePulseLaser
             & ix 0 . mzAmmoSlot .~ CapacitorBelow (UseExactly 200)
+    | PlasmaSF <- loc ^. locDT . dtValue . _2 =
+        dbwMuzzles
+            & ix 0 . mzEffect .~ MuzzlePlasmaBall
+            & ix 0 . mzAmmoSlot .~ CapacitorSelf (UseExactly 1)
+            & ix 0 . mzInaccuracy .~ 0
+            & ix 0 . mzFlareType .~ TeslaGunFlare
     | PulseBallSF <- loc ^. locDT . dtValue . _2 =
         dbwMuzzles
             & ix 0 . mzEffect .~ MuzzlePulseBall
             & ix 0 . mzAmmoSlot .~ CapacitorSelf (UseExactly 200)
             & ix 0 . mzInaccuracy .~ 0
             & ix 0 . mzFlareType .~ TeslaGunFlare
-    | otherwise = itemMuzzles $ loc ^. locDT . dtValue . _1
+--    | otherwise = itemMuzzles $ loc ^. locDT . dtValue . _1
+    | otherwise = itemMuzzles $ loc
 
-itemMuzzles :: Item -> [Muzzle]
+itemMuzzles :: LocationDT OItem -> [Muzzle]
-itemMuzzles itm = case itm ^. itType of
+itemMuzzles loc = case itm ^. itType of
-    HELD hit -> heldItemMuzzles itm hit
+    HELD hit -> heldItemMuzzles loc hit
     DETECTOR{} ->
         dbwMuzzles & ix 0 . mzEffect .~ MuzzleDetector
             & ix 0 . mzAmmoSlot . aps .~ UseExactly 100
@@ -174,9 +182,11 @@ itemMuzzles itm = case itm ^. itType of
             & ix 0 . mzFlareType .~ LasGunFlare
             & ix 0 . mzEffect .~ MuzzleLaser
     _ -> []
+  where
+    itm = loc ^. locDT . dtValue . _1
 
-heldItemMuzzles :: Item -> HeldItemType -> [Muzzle]
+heldItemMuzzles :: LocationDT OItem -> HeldItemType -> [Muzzle]
-heldItemMuzzles itm = \case
+heldItemMuzzles loc = \case
     ALTERIFLE ->
         dbwMuzzles & ix 0 . mzPos .~ V2 25 0
             & ix 0 . mzAmmoSlot .~ MagBelow (_alteRifleSwitch (_itParams itm)) (UseExactly 1)
@@ -246,6 +256,9 @@ heldItemMuzzles itm = \case
     BLUNDERBUSS -> [Muzzle (V2 30 0) 0 0.5 magupto15 BasicFlare MuzzleShootBullet 12]
     GRAPECANNON i -> [Muzzle (V2 30 0) 0 0.5 magupto15 BasicFlare MuzzleShootBullet (12 + 4 * fromIntegral i)]
     LED -> dbwMuzzles & ix 0 . mzPos .~ V2 10 0
+            -- don't care where the pump is, but possibly should know this
+    FLAMETHROWER | any (\dt -> Just PumpSF == dt ^? dtValue . _2) (loc ^. locDT . dtRight)
+            -> flameMuzzles & ix 0 . mzEffect . nzPressure .~ UniRandFloat 2 8
     FLAMETHROWER -> flameMuzzles
     FLAMESPITTER -> flameMuzzles & ix 0 . mzEffect . nzPressure .~ UniRandFloat 3 4
     RLAUNCHER ->
@@ -266,9 +279,9 @@ heldItemMuzzles itm = \case
                 <*> pure MuzzleRLauncher
                 <*> pure 0
             )
-    TESLAGUN ->
+    TESLACOIL ->
         dbwMuzzles
-            & ix 0 . mzPos .~ V2 10 0
+            & ix 0 . mzPos .~ V2 5 0
             & ix 0 . mzInaccuracy .~ 0
             & ix 0 . mzFlareType .~ TeslaGunFlare
             & ix 0 . mzEffect .~ MuzzleTesla
@@ -318,6 +331,7 @@ heldItemMuzzles itm = \case
   where
     maguse1 = MagBelow 0 (UseExactly 1)
     magupto15 = MagBelow 0 (UseUpTo 15)
+    itm = loc ^. locDT . dtValue . _1
 
 baseStickSpread :: Float
 baseStickSpread = 0.2
@@ -334,7 +348,8 @@ flameMuzzles =
         (MagBelow 0 (UseExactly 1))
         NoFlare
         MuzzleNozzle
-            { _nzPressure = ConstFloat 4
+            --{ _nzPressure = ConstFloat 4
+            { _nzPressure = UniRandFloat 3.5 4
             , _nzMaxWalkAngle = 0.2
             , _nzWalkSpeed = 0.01
             }
@@ -414,8 +429,7 @@ itemSidePush = \case
     FLAMETORRENT -> 0
     FLAMEWALL -> 0
     BLOWTORCH -> 0
-    SPARKGUN -> 0
+    TESLACOIL -> 0
-    TESLAGUN -> 0
     TRACTORGUN -> 0
     RLAUNCHER -> 0
     RLAUNCHERX{} -> 0
@@ -497,8 +511,7 @@ recoilAmount itm
         FLAMETORRENT -> 0
         FLAMEWALL -> 0
         BLOWTORCH -> 0
-        SPARKGUN -> 0
+        TESLACOIL -> 0
-        TESLAGUN -> 0
         TRACTORGUN -> 0
         RLAUNCHER -> 0
         RLAUNCHERX _ -> 0
@@ -544,8 +557,7 @@ bgunSound itm
         FLAMETORRENT -> Nothing
         FLAMEWALL -> Nothing
         BLOWTORCH -> Nothing
-        SPARKGUN -> Nothing
+        TESLACOIL -> Nothing
-        TESLAGUN -> Nothing
         TRACTORGUN -> Nothing
         RLAUNCHER -> Just (tap4S, 0)
         RLAUNCHERX _ -> Just (tap4S, 0)
@@ -615,8 +627,7 @@ heldTorqueAmount = \case
     FLAMETORRENT -> 0
     FLAMEWALL -> 0
     BLOWTORCH -> 0
-    SPARKGUN -> 0
+    TESLACOIL -> 0.01
-    TESLAGUN -> 0.01
     TRACTORGUN -> 0
     RLAUNCHER -> 0
     RLAUNCHERX{} -> 0
@@ -728,6 +739,7 @@ useLoadedAmmo loc cr mz m w =
         MuzzleLaser -> creatureShootLaser pq' loc (w & randGen .~ g)
         MuzzlePulseLaser -> creatureShootPulseLaser pq' cr (w & randGen .~ g)
         MuzzlePulseBall -> shootPulseBall pq' (w & randGen .~ g)
+        MuzzlePlasmaBall -> shootPlasmaBall pq' (w & randGen .~ g)
         MuzzleTesla -> shootTeslaArc pq' loc (w & randGen .~ g)
         MuzzleTractor -> shootTractorBeam cr w
         MuzzleRLauncher -> createProjectileR pq loc magtree cr w
@@ -888,6 +900,18 @@ shootPulseLaser so p dir w =
                 }
         & soundStart so p lasPulseS Nothing
 
+shootPlasmaBall :: Point3Q -> World -> World
+shootPlasmaBall (p, q) w =
+    w
+        & cWorld . lWorld . plasmaBalls .:~
+            PBall
+                { _pbPos = p ^. _xy
+                , _pbVel = 6 * unitVectorAtAngle (Q.qToAng q)
+                , _pbType = DefaultPlasma
+                }
+--        & soundStart (PBSound i) (p ^. _xy) energyReleaseS Nothing
+
+
 shootPulseBall :: Point3Q -> World -> World
 shootPulseBall (p, q) w =
     w
@@ -1021,8 +1045,7 @@ heldItemMuzVel = \case
     FLAMETORRENT -> ConstFloat 0.8
     FLAMEWALL -> ConstFloat 0.8
     BLOWTORCH -> ConstFloat 0.8
-    SPARKGUN -> ConstFloat 0.8
+    TESLACOIL -> ConstFloat 0.8
-    TESLAGUN -> ConstFloat 0.8
     TRACTORGUN -> ConstFloat 0.8
     RLAUNCHER -> ConstFloat 0
     RLAUNCHERX{} -> ConstFloat 0
@@ -1064,8 +1087,7 @@ heldItemRifling = \case
     FLAMETORRENT -> ConstFloat 0.8
     FLAMEWALL -> ConstFloat 0.8
     BLOWTORCH -> ConstFloat 0.8
-    SPARKGUN -> ConstFloat 0.8
+    TESLACOIL -> ConstFloat 0.8
-    TESLAGUN -> ConstFloat 0.8
     TRACTORGUN -> ConstFloat 0.8
     RLAUNCHER -> ConstFloat 0
     RLAUNCHERX{} -> ConstFloat 0
@@ -1136,8 +1158,7 @@ gasType hit _ = case hit of
     FLAMETORRENT -> Just CreateFlame
     FLAMEWALL -> Just CreateFlame
     BLOWTORCH -> Nothing
-    SPARKGUN -> Nothing
+    TESLACOIL -> Nothing
-    TESLAGUN -> Nothing
     TRACTORGUN -> Nothing
     RLAUNCHER -> Nothing
     RLAUNCHERX{} -> Nothing
@@ -1365,7 +1386,7 @@ dropInventoryPath i ip loc cr = fromMaybe id $ do
 --        guard $ (i + j) `IM.member` (cr ^. crInv)
 --        return $ dropItem cr (i + j) w
 --    RELITEM -> fromMaybe w $ do
---        j <- loc ^? locLDT . ldtValue . _1 . itLocation . ilInvID
+--        j <- loc ^? locDT . dtValue . _1 . itLocation . ilInvID
 --        guard $ (i + j) `IM.member` (cr ^. crInv)
 --        return $ dropItem cr (i + j) w
 

src/Dodge/Item.hs

@@ -62,6 +62,7 @@ itemFromAttachType = \case
     HOMINGMODULE -> homingModule
     SHELLPAYLOAD p -> shellModule p
     CAPACITOR -> capacitor
+    COMPRESSOR -> compressor
 
 itemFromEquipType :: EquipItemType -> Item
 itemFromEquipType et = case et of

src/Dodge/Item/AimStance.hs

@@ -50,8 +50,7 @@ heldAimStance = \case
     FLAMETORRENT -> TwoHandUnder
     FLAMEWALL -> TwoHandUnder
     BLOWTORCH -> TwoHandUnder
-    SPARKGUN -> TwoHandFlat
+    TESLACOIL -> TwoHandFlat
-    TESLAGUN -> TwoHandFlat
     TRACTORGUN -> TwoHandUnder
     RLAUNCHER -> TwoHandOver
     RLAUNCHERX{} -> TwoHandOver

src/Dodge/Item/Ammo.hs

@@ -11,6 +11,7 @@ module Dodge.Item.Ammo (
     megaTinMag,
     megaBattery,
     capacitor,
+    compressor,
 ) where
 
 import Control.Lens
@@ -70,6 +71,13 @@ capacitor =
         & itUse .~ UseNothing
         & itConsumables ?~ 0
 
+compressor :: Item
+compressor =
+    defHeldItem
+        & itType .~ ATTACH COMPRESSOR
+        & itUse .~ UseNothing
+        & itConsumables ?~ 0
+
 chemFuelPouch :: Item
 chemFuelPouch =
     defHeldItem

src/Dodge/Item/AmmoSlots.hs

@@ -45,8 +45,7 @@ heldItemAmmoSlots = \case
     FLAMESPITTER -> singleAmmo GasAmmo
     FLAMEWALL -> singleAmmo GasAmmo
     BLOWTORCH -> singleAmmo GasAmmo
-    TESLAGUN -> singleAmmo ElectricalAmmo
+    TESLACOIL -> singleAmmo ElectricalAmmo
-    SPARKGUN -> singleAmmo ElectricalAmmo
     TRACTORGUN -> singleAmmo ElectricalAmmo
     SHATTERGUN -> singleAmmo ElectricalAmmo
     LED -> singleAmmo ElectricalAmmo

src/Dodge/Item/Display.hs

@@ -103,6 +103,7 @@ showAttachItem = \case
     GIMBAL -> "GIMBAL"
     GYROSCOPE -> "GYROSCOPE"
     CAPACITOR -> "CAPACITOR"
+    COMPRESSOR -> "COMPRESSOR"
 
 showEquipItem :: EquipItemType -> String
 showEquipItem eit = case eit of

src/Dodge/Item/Draw/SPic.hs

@@ -259,8 +259,7 @@ heldItemSPic ht it = case ht of
     FLAMETORRENT -> flamerPic it
     FLAMEWALL -> flamerPic it
     BLOWTORCH -> flamerPic it
-    SPARKGUN -> teslaGunPic
+    TESLACOIL -> teslaGunPic
-    TESLAGUN -> teslaGunPic
     TRACTORGUN -> tractorGunPic it
     RLAUNCHER -> rlauncherPic it
     RLAUNCHERX _ -> rlauncherPic it

src/Dodge/Item/Grammar.hs

@@ -36,16 +36,19 @@ tryAttachItems = leftRightCombine leftIsParentCombine rightIsParentCombine
 
 itemAboveAttachables :: CItem -> [ItemSF]
 itemAboveAttachables (itm,sf) = case (itm ^. itType, sf) of
-    (_, HeldPlatformSF) ->
+    (HELD FLAMETHROWER,_) -> PumpSF:helddefaults
-         [WeaponTargetingSF, WeaponScopeSF,TorchSF]
+    (_, HeldPlatformSF) -> helddefaults
-            <> getAutoSpringLinks itm
-            <> extraWeaponLinks itm
     (DETECTOR {}, _) -> [ARHUDSF,TriggerSF,MapperSF]
     --(CRAFT TRANSFORMER, _) ->  [LaserWeaponSF]
     (LASER, _) ->  [TransformerSF]
     (MAPPER, _) -> [ARHUDSF]
     (_, GadgetPlatformSF) -> [TriggerSF, WeaponTargetingSF, WeaponScopeSF]
     _ -> []
+  where
+    helddefaults = 
+         [WeaponTargetingSF, WeaponScopeSF,TorchSF]
+            <> getAutoSpringLinks itm
+            <> extraWeaponLinks itm
 
 itemBelowAttachables :: CItem -> [ItemSF]
 itemBelowAttachables (itm,sf) = case (itm ^. itType, sf) of
@@ -138,6 +141,7 @@ itemToFunction itm = case itm ^. itType of
     CLICKER{} -> GadgetPlatformSF
     ATTACH CAPACITOR -> CapacitorSF
     CRAFT TRANSFORMER -> TransformerSF
+    CRAFT PUMP -> PumpSF
     _ -> NoSF
 
 treeToPotentialFunction :: DTree CItem -> S.Set ItemSF

src/Dodge/Item/Held.hs

@@ -58,8 +58,7 @@ itemFromHeldType ht = case ht of
     FLAMETORRENT -> flameTorrent
     FLAMEWALL -> flameWall
     BLOWTORCH -> blowTorch
-    SPARKGUN -> sparkGun
+    TESLACOIL -> teslaCoil
-    TESLAGUN -> teslaGun
 --    LASCIRCLE -> lasCircle
 --    DUALBEAM -> dualBeam
 --    LASWIDE i -> lasWide i

src/Dodge/Item/Held/BatteryGuns.hs

@@ -1,6 +1,5 @@
 module Dodge.Item.Held.BatteryGuns (
-    sparkGun,
+    teslaCoil,
-    teslaGun,
     laser,
     tractorGun,
 ) where
@@ -10,17 +9,11 @@ import Dodge.Data.Item
 import Dodge.Default.Item
 --import Geometry.Data
 
-sparkGun :: Item
+teslaCoil :: Item
-sparkGun =
+teslaCoil =
-    teslaGun
-        & itType .~ HELD SPARKGUN
---        & itParams . arcSize .~ 10
-
-teslaGun :: Item
-teslaGun =
     defHeldItem
         & itParams .~ teslaParams
-        & itType .~ HELD TESLAGUN
+        & itType .~ HELD TESLACOIL
 
 teslaParams :: ItemParams
 teslaParams =

src/Dodge/Item/HeldOffset.hs

@@ -110,8 +110,7 @@ heldHandlePos = \case
     FLAMETORRENT -> V2 3 0
     FLAMEWALL -> V2 3 0
     BLOWTORCH -> V2 3 0
-    SPARKGUN -> V2 3 0
+    TESLACOIL -> V2 3 0
-    TESLAGUN -> V2 3 0
     TRACTORGUN -> V2 3 0
     RLAUNCHER -> V2 3 0
     RLAUNCHERX{} -> V2 3 0

src/Dodge/Item/Info.hs

@@ -121,8 +121,7 @@ heldInfo hit = case hit of
     FLAMETORRENT -> "A weapon that streams out burning fuel in a torrent."
     FLAMEWALL -> "A weapon that squirts out burning fuel all around the user."
     BLOWTORCH -> "A weapon that produces a concentrated flame."
-    SPARKGUN -> "A weapon that produces an arc of electricity. The arc will attempt to discharge at a nearby object."
+    TESLACOIL -> "An item that creates an arc of electricity."
-    TESLAGUN -> "A weapon that discharges a sustained arc of electricity. The arc will attempt to discharge at a nearby object."
     TRACTORGUN -> "An item that produces a beam of gravitons."
     GLAUNCHER -> "A large tube that can launch projectiles."
     RLAUNCHER -> "A large tube that can launch self propelled projectiles. Moving the tube after launch will cause the projectile to spin."

src/Dodge/Item/InvSize.hs

@@ -20,7 +20,7 @@ itInvHeight x = case x ^. itType of
 
 itDim :: Item -> ItemDimension
 itDim x = case x ^. itType of
-    HELD TESLAGUN -> ItemDimension 9 (V3 4 0 0) (V3 10 (-5) 3)
+    HELD TESLACOIL -> ItemDimension 9 (V3 4 0 0) (V3 10 (-5) 3)
     LASER -> did & dimRad .~ 10
         & dimCenter .~ V3 15 0 0
     HELD TRACTORGUN -> did & dimRad .~ 10

src/Dodge/Item/InventoryColor.hs

@@ -42,7 +42,9 @@ sfInvColor = \case
     PulseLaserSF -> white
     CapacitorSF -> yellow
     PulseBallSF -> white
+    PlasmaSF -> white
     TransformerSF -> yellow
+    PumpSF -> yellow
     TorchSF{} -> green
 
 --ammoTypeColor :: AmmoType -> Color

src/Dodge/Layout.hs

@@ -1,25 +1,27 @@
 {-# LANGUAGE TupleSections #-}
+
 module Dodge.Layout (
     generateLevelFromRoomList,
     tilesFromRooms,
     shuffleRoomPos,
 ) where
 
-import qualified Data.Vector.Unboxed as UV
+-- import Dodge.Path.Translate
---import Dodge.Path.Translate
 import qualified Control.Foldl as L
 import Control.Lens
 import Data.Foldable
 import Data.Function
---import Data.Graph.Inductive (labEdges, labNodes)
+import Linear
-import Data.List (nubBy,sortOn)
+-- import Data.Graph.Inductive (labEdges, labNodes)
+import Data.List (nubBy, sortOn)
 import Data.Maybe
 import Data.Tile
---import Data.Traversable
+import qualified Data.Vector.Unboxed as UV
+-- import Data.Traversable
 import Dodge.Data.GenWorld
 import Dodge.Default.Wall
 import Dodge.GameRoom
---import Dodge.Item.Location.Initialize
+-- import Dodge.Item.Location.Initialize
 import Dodge.LevelGen.LevelStructure
 import Dodge.LevelGen.StaticWalls
 import Dodge.Path
@@ -37,29 +39,27 @@ generateLevelFromRoomList gr' w =
     over gwWorld initWallZoning
         . over gwWorld randomCompass
         . over gwWorld setupWorldBounds
---        . over (gwWorld . cWorld . lWorld) initItemLocations
         . doInPlacements
---        . doOutPlacements
         . doIndividualPlacements
         . setTiles
         . worldToGenWorld rs'
-        $ w & cWorld . lWorld . walls .~ wallsFromRooms rs
+        $ w
+            & cWorld . lWorld . walls .~ wallsFromRooms rs
             & cWorld . cwGen . cwgGameRooms .~ gameRoomsFromRooms (IM.elems rs')
             & cWorld . incNode .~ inodes
             & cWorld . incGraph .~ igraph
             & cWorld . incEdges .~ ipairs
-            & incNodeZoning .~ UV.ifoldl' (\m i p -> zonePn (i,p) m) mempty inodes
+            & incNodeZoning .~ UV.ifoldl' (\m i p -> zonePn (i, p) m) mempty inodes
             & incEdgeZoning .~ foldl' (flip (zoneIncPe inodes)) mempty ipairs
   where
     pairs = snapToGrid $ foldMap _rmPath rs
-    (inodes,igraph,ipairs) = pairsToIncGraph pairs
+    (inodes, igraph, ipairs) = pairsToIncGraph pairs
     rs = map doRoomShift $ IM.elems rs'
     rs' = mapM shuffleRoomPos gr' & evalState $ _randGen w
 
-
 randomCompass :: World -> World
-randomCompass w = w 
+randomCompass w =
-    & wCam . camRot .~ (takeOne [0, 0.5 * pi, pi, 1.5 * pi] & evalState $ _randGen w)
+    w & wCam . camRot .~ (takeOne [0, 0.5 * pi, pi, 1.5 * pi] & evalState $ _randGen w)
 
 -- note the order of traversal of the rooms is important
 -- hence the reverse
@@ -70,52 +70,56 @@ setTiles gw = foldr setTile gw . reverse . IM.elems $ _genRooms gw
 setTile :: Room -> GenWorld -> GenWorld
 setTile r gw = case _rmFloor r of
     Tiled{} -> gw
-    InheritFloor -> gw 
+    InheritFloor ->
-        & genRooms . ix (fromJust (_rmMID r)) . rmFloor .~ Tiled [t & tilePoly .~ poly]
+        gw & genRooms . ix (fromJust (_rmMID r)) . rmFloor .~ Tiled [t & tilePoly .~ poly]
   where
     t = case _rmMParent r of
         Nothing -> Tile poly (V2 0 0) (V2 1 0) 16
         Just pid -> head $ _tiles $ _rmFloor $ _genRooms gw IM.! pid
-    poly = orderPolygon . convexHullSafe 
+    poly =
-        . nubBy ((==) `on` roundPoint2) $ concat $ _rmPolys r
+        orderPolygon
+            . convexHullSafe
+            . nubBy ((==) `on` roundPoint2)
+            . concat
+            $ _rmPolys r
 
-shuffleRoomPos :: RandomGen g => Room -> State g Room
+shuffleRoomPos :: (RandomGen g) => Room -> State g Room
-shuffleRoomPos rm = do
+shuffleRoomPos = rmPos shuffle
-    newPos <- shuffle $ _rmPos rm
-    return $ rm & rmPos .~ newPos
 
 doInPlacements :: GenWorld -> GenWorld
-doInPlacements w = foldl' (\gw (i,(_,f)) -> placeSpot i gw (f gw)) w
+doInPlacements w =
-    . sortOn (fst.snd)
+    foldl' (\gw (i, (_, f)) -> rplaceSpot i gw (f gw)) w
-    $ foldMap g $ w ^. genRooms
+        . sortOn (fst . snd)
+        . foldMap g
+        $ w ^. genRooms
   where
-    g rm = (rm^?! rmMID . _Just,) <$> (rm ^. rmInPmnt)
+    g rm = (rm ^?! rmMID . _Just,) <$> (rm ^. rmInPmnt)
---    let (gw, rms) = mapAccumR doRoomInPlacements w (_genRooms w)
+    rplaceSpot i gw rx = placeSpot i (gw & gwWorld . randGen .~ gen) x
---     in gw & genRooms .~ rms
+      where
-
+        (x,gen) = runState rx (gw ^. gwWorld . randGen)
---doRoomInPlacements :: GenWorld -> Room -> (GenWorld, Room)
---doRoomInPlacements w rm = foldr f (w, rm) $ _rmInPmnt rm
---  where
---    f plf (w', r') =  placeSpot (w', r') (plf w')
 
 doIndividualPlacements :: GenWorld -> GenWorld
 doIndividualPlacements gw = foldl' doRoomPlacements gw (_genRooms gw)
 
 doRoomPlacements :: GenWorld -> Room -> GenWorld
-doRoomPlacements w rm = foldl' (placeSpot i) (w & genRooms . ix i . rmPmnts .~ mempty) 
+doRoomPlacements w rm =
+    foldl' (placeSpot i) (w & genRooms . ix i . rmPmnts .~ mempty)
+        . sortOn plPriority
         $ _rmPmnts rm
   where
     i = rm ^?! rmMID . _Just
 
---placeSpot' :: Int -> GenWorld -> Placement -> GenWorld
+plPriority :: Placement -> Int
---placeSpot' = placeSpot
+plPriority pl = case pl ^. plType of
---placeSpot' i gw x = 
+    PutChasm{} -> 0
---    let (gw',r') = placeSpot (gw,(gw ^?! genRooms . ix i)) x
+    PutBlock{} -> 1
---    in gw' & genRooms . ix i .~ r'
+    PutDoor{} -> 2
+    _ -> 3
 
 setupWorldBounds :: World -> World
 setupWorldBounds w =
-    w & cWorld . cwGen . cwgWorldBounds
+    w
+        & cWorld . cwGen . cwgWorldBounds
             %~ ( (bdMinX .~ f minx)
                     . (bdMaxX .~ f maxx)
                     . (bdMinY .~ f miny)
@@ -154,12 +158,15 @@ gameRoomFromRoom rm =
     GameRoom
         { _grViewpoints =
             map doshift $
-                _rmViewpoints rm ++ (map fst . foldl' (flip cutWalls) [] $ _rmPolys rm)
+                _rmViewpoints rm
+                    ++ (map fst . foldl' (flip cutWalls) [] $ _rmPolys rm)
                     ++ mapMaybe filterUnusedLinks (_rmPos rm)
         , _grViewpointsEx = concatMap filterUsedLinks (_rmPos rm)
         , _grBound =
-            map doshift $
+            map doshift
-                expandPolyCorners 50 . convexHullSafe . nubBy closePoints
+                $ expandPolyCorners 50
+                    . convexHullSafe
+                    . nubBy closePoints
                     . concat
                 $ _rmBound rm ++ _rmPolys rm
         , _grRmBounds = map (map doshift) $ _rmBound rm
@@ -172,8 +179,8 @@ gameRoomFromRoom rm =
     doubleShift p a =
         map
             doshift
-            [ p +.+ 10 *.* unitVectorAtAngle a
+            [ p + 10 *^ unitVectorAtAngle a
-            , p -.- 10 *.* unitVectorAtAngle a
+            , p - 10 *^ unitVectorAtAngle a
             ]
     filterUnusedLinks rp = case _rpType rp of
         UnusedLink{} -> Just $ _rpPos rp
@@ -202,36 +209,36 @@ getTiles fl = case fl of
     Tiled xs -> xs
     _ -> error "tiles not correctly set for some room"
 
---divideWall :: Wall -> [Wall]
+-- divideWall :: Wall -> [Wall]
---divideWall wl
+-- divideWall wl
 --    = let (a,b) = _wlLine wl
 --          ps = divideLine (zoneSize * 2) a b
 --      in  zipWith (\ x y -> wl & wlLine .~ (x,y) ) (init ps) (tail ps)
 
---divideWallIn :: Wall -> IM.IntMap Wall -> IM.IntMap Wall
+-- divideWallIn :: Wall -> IM.IntMap Wall -> IM.IntMap Wall
---divideWallIn wl wls =
+-- divideWallIn wl wls =
 --    let (wl':newWls) = divideWall wl
 --        k = IM.newKey wls
 --        newWls' = zipWith (\i w -> w {_wlID = i}) [k..] newWls
 --    in  foldl' (flip $ \w -> IM.insert (_wlID w) w) wls (wl':newWls')
 --
---divideWalls :: IM.IntMap Wall -> IM.IntMap Wall
+-- divideWalls :: IM.IntMap Wall -> IM.IntMap Wall
---divideWalls wls = foldl' (flip divideWallIn) wls wls
+-- divideWalls wls = foldl' (flip divideWallIn) wls wls
 
---insertInZone :: Int -> Int -> a -> IM.IntMap (IM.IntMap a) -> IM.IntMap (IM.IntMap a)
+-- insertInZone :: Int -> Int -> a -> IM.IntMap (IM.IntMap a) -> IM.IntMap (IM.IntMap a)
---insertInZone x y obj = IM.insertWith f x $ IM.singleton y obj
+-- insertInZone x y obj = IM.insertWith f x $ IM.singleton y obj
 --    where f _ = IM.insert y obj
 
---shiftRoomTree :: Tree Room -> Tree Room
+-- shiftRoomTree :: Tree Room -> Tree Room
---shiftRoomTree (Node t []) = Node t []
+-- shiftRoomTree (Node t []) = Node t []
---shiftRoomTree (Node t ts) = Node t
+-- shiftRoomTree (Node t ts) = Node t
 --    $ zipWith (\l -> shiftRoomTree . applyToRoot (shiftRoomToLink l))
 --    (_rmLinks t)
 --    ts
 
---shiftRoomTreeConstruction :: Tree Room -> [Tree Room]
+-- shiftRoomTreeConstruction :: Tree Room -> [Tree Room]
---shiftRoomTreeConstruction (Node t []) = [Node t []]
+-- shiftRoomTreeConstruction (Node t []) = [Node t []]
---shiftRoomTreeConstruction (Node t ts) = (Node t [] :) $ concat $
+-- shiftRoomTreeConstruction (Node t ts) = (Node t [] :) $ concat $
 --    zipWith (\l -> shiftRoomTreeConstruction . applyToRoot (shiftRoomBy l . f))
 --    (_rmLinks t)
 --    ts
@@ -240,8 +247,8 @@ getTiles fl = case fl of
 --      where
 --        (p,a) = last $ _rmLinks r
 
---addTile :: Float -> Room -> Room
+-- addTile :: Float -> Room -> Room
---addTile z r
+-- addTile z r
 --    | not (null (_rmFloor r)) || null rp = r
 --    | otherwise = r & rmFloor .~ [makeTileFromPoly poly z]
 --  where

src/Dodge/LevelGen.hs

@@ -31,6 +31,7 @@ generateWorldFromSeed rdata i = do
 postGenerationProcessing :: RenderData -> GenWorld -> IO World
 postGenerationProcessing _ gw = do
     let w = _gwWorld gw & cWorld . cwTiles .~ (tilesFromRooms . IM.elems $ _genRooms gw)
+    putStrLn $ show $ gw ^. genInts
     return $ foldl' assignPushDoors w (w ^. cWorld . lWorld . doors)
 
 assignPushDoors :: World -> Door -> World

src/Dodge/LockAndKey.hs

@@ -1,5 +1,6 @@
 module Dodge.LockAndKey where
 
+import Dodge.Item.Ammo
 import Dodge.Cleat
 import Dodge.Creature
 import Dodge.Data.GenWorld
@@ -24,13 +25,13 @@ lockRoomMultiItems =
 
 lockRoomKeyItems :: [(Int -> State LayoutVars (MetaTree Room String), State LayoutVars ItemType)]
 lockRoomKeyItems =
-    [ (lasCenSensEdge, takeOne [HELD RLAUNCHER, LASER, HELD SPARKGUN, HELD FLATSHIELD])
+--    [ (lasCenSensEdge, takeOne [LASER,HELD TESLACOIL, HELD FLATSHIELD])
-    , (sensorRoomRunPast LaserSensor, return LASER)
+--    , (sensorRoomRunPast LaserSensor, return LASER)
-    , (const slowDoorRoomRunPast, return $ HELD (MINIGUNX 3))
+--    [ (const slowDoorRoomRunPast, return $ HELD (MINIGUNX 3))
-    , (const longRoomRunPast, takeOne [HELD SNIPERRIFLE, HELD FLATSHIELD])
+--    [ (const longRoomRunPast, takeOne [HELD SNIPERRIFLE, HELD FLATSHIELD])
-    , (const glassLessonRunPast, takeOne [LASER])
+--    [ (const glassLessonRunPast, takeOne [LASER])
-    , (const $ lasTunnelRunPast 400, takeOne [HELD FLATSHIELD])
+    [ (const $ lasTunnelRunPast 400, takeOne [HELD FLATSHIELD])
-    , (keyCardRoomRunPast 0, return (HELD $ KEYCARD 0))
+--    , (keyCardRoomRunPast 0, return (HELD $ KEYCARD 0))
     ]
 
 keyCardRunPastRand :: RandomGen g => [(Int -> State g (MetaTree Room String), State g ItemType)]
@@ -58,14 +59,15 @@ itemRooms =
         ( LASER
         , join $
             takeOne
-                [ rc $ map makeTypeCraft [PRISM, TRANSFORMER, PIPE]
+                [ rc $ battery : map makeTypeCraft [PRISM, TRANSFORMER, PIPE, TRANSFORMER]
+                , rc $ battery : laser : [makeTypeCraft TRANSFORMER]
                 ]
         )
     ,
-        ( HELD SPARKGUN
+        ( HELD TESLACOIL
         , join $
             takeOne
-                [ rc $ map makeTypeCraft [TRANSFORMER, CAN, CAN]
+                [ rc (battery : map makeTypeCraft [TRANSFORMER, CAN, CAN])
                 ]
         )
     ,

src/Dodge/Material/Color.hs

@@ -16,3 +16,7 @@ materialColor = \case
     Flesh -> red
     Electronics -> greyN 0.2
     ForceField -> magenta
+    Photovoltaic -> yellow
+    LightningRod -> yellow
+    Pyroelectric -> yellow
+    Piezoelectric -> yellow

src/Dodge/Material/Damage.hs

@@ -25,13 +25,18 @@ damMatSideEffect dm = \case
     Dirt -> damageDirt dm
     Glass -> damageGlass dm
     Crystal -> damageCrystal dm
+    Photovoltaic -> damagePhotovoltaic dm
+    LightningRod -> damageLightningRod dm
+    Pyroelectric ->  damagePyroelectric dm
+    Piezoelectric -> damagePiezoelectric dm
     _ -> defDamageMaterial dm
 
 defDamageMaterial :: Damage -> ECW -> World -> (Int,World)
 defDamageMaterial dm _ = (dm ^. dmAmount,)
 
-laserSpark x y -- = makeSpark FireSpark x y
+laserSpark :: Point2 -> Float -> World -> World
-    = id
+--laserSpark x y = makeSpark FireSpark x y
+laserSpark = makeSpark FireSpark
 
 damageStone :: Damage -> ECW -> World -> (Int,World)
 damageStone dm ecw w = case dm of
@@ -65,6 +70,56 @@ damageStone dm ecw w = case dm of
     so = DamageHitSound (w ^. cWorld . lWorld . lClock)
     outTo x t = x -.- squashNormalizeV t
 
+damageLightningRod :: Damage -> ECW -> World -> (Int,World)
+damageLightningRod dm ecw w = case dm of
+    Electrical{} -> (dm ^. dmAmount, w)
+    _ -> damageStone dm ecw w
+
+damagePyroelectric :: Damage -> ECW -> World -> (Int,World)
+damagePyroelectric dm ecw w = case dm of
+    Flaming{} -> (dm ^. dmAmount, w)
+    Explosive{} -> (dm ^. dmAmount, w)
+    Sparking{} -> (dm ^. dmAmount, w)
+    _ -> damageStone dm ecw w
+
+-- this should be correct
+-- to be honest, we shouldn't just pass an int forward here...
+damagePiezoelectric :: Damage -> ECW -> World -> (Int,World)
+damagePiezoelectric = damageStone
+    
+
+damagePhotovoltaic :: Damage -> ECW -> World -> (Int,World)
+damagePhotovoltaic dm ecw w = case dm of
+        Lasering _ p t -> f (10*dmam) $ laserSpark (outTo p t) (rdir p t)
+        Piercing _ p t -> 
+            f dmam $ makeSpark NormalSpark (outTo p t) (rdir p t)
+                . makeDustAt Stone 200 (addZ 20 (outTo p t))
+--                . randsound p [slapS, slap1S,slap2S,slap3S,slap4S,slap5S,slap6S,slap7S]
+                . randsound p [slapS, slap1S, slap2S]
+        Blunt _ p t -> f dmam $ makeDustAt Stone 200 (addZ 20 (outTo p t))
+        Shattering _ p t -> f dmam $ makeDustAt Stone 200 (addZ 20 (outTo p t))
+        Crushing{} -> f dmam  id
+        Explosive{} -> f dmam  id
+        Sparking{} -> f 0  id
+        Flaming{} -> f 0  id
+        Electrical{} -> f 0  id
+        Poison{} -> f 0  id
+        Enterrement{} -> f 0  id
+        Flashing{} -> f 0  id
+  where
+    f x g = (x, g w)
+    dmam = dm ^. dmAmount
+    rdir p t = argV $ reflectIn v t
+      where
+        v = case ecw of
+            Right wl -> uncurry (-) $ _wlLine wl
+            Left cr -> vNormal (p - cr ^. crPos . _xy)
+    randsound p xs =
+        let (x, g) = runState (takeOne xs) $ _randGen w
+         in soundStart so p x Nothing . set randGen g
+    so = DamageHitSound (w ^. cWorld . lWorld . lClock)
+    outTo x t = x -.- squashNormalizeV t
+
 damageMetal :: Damage -> ECW -> World -> (Int,World)
 damageMetal dm ecw w = case dm of
         Lasering _ p t -> f 0 $ laserSpark (outTo p t) (rdir p t)

src/Dodge/Material/Sound.hs

@@ -15,6 +15,10 @@ destroyMatS mat = case mat of
     Electronics -> [metal1S, metal2S, metal3S, metal4S, metal5S, metal6S,metal7S]
     Flesh -> [gut1S, gut2S, gut3S, gut4S, gut5S, gut6S]
     ForceField -> []
+    Photovoltaic -> [glassShat1S, glassShat2S, glassShat3S, glassShat4S]
+    LightningRod  -> [glassShat1S, glassShat2S, glassShat3S, glassShat4S]
+    Pyroelectric  -> [glassShat1S, glassShat2S, glassShat3S, glassShat4S]
+    Piezoelectric -> [glassShat1S, glassShat2S, glassShat3S, glassShat4S]
 
 --weakenMatS :: Material -> [SoundID]
 --weakenMatS mat = case mat of

src/Dodge/Placement/Instance/LightSource.hs

@@ -1,8 +1,11 @@
 module Dodge.Placement.Instance.LightSource (
     mntLSOn,
+    mntLSCond,
     aShape,
     aBar,
     lShape,
+    jShape,
+    liShape,
     mntLightLnkCond,
     mntLS,
     vShape,
@@ -13,6 +16,7 @@ module Dodge.Placement.Instance.LightSource (
     spanLightY,
     mntLightLnkCond',
     spanLS,
+    mntLightLnkShape,
 ) where
 
 import Color
@@ -145,6 +149,9 @@ mntLightLnkCond ps = do
     shp <- takeOne [vShape, lShape, jShape, liShape]
     return $ mntLSCond (fmap (fmap $ colorSH black) shp) ps
 
+mntLightLnkShape :: (Point2 -> Point3 -> Shape) -> PlacementSpot -> Placement
+mntLightLnkShape shp ps = mntLSCond (fmap (fmap $ colorSH black) shp) ps
+
 mntLightLnkCond' :: PlacementSpot -> Placement
 mntLightLnkCond' = mntLSCond (fmap (fmap $ colorSH black) vShape)
 
@@ -178,7 +185,8 @@ spanColLightBlackI col h a b =
     V2 x y = 0.5 *.* (a +.+ b)
 
 spanLightI :: Point2 -> Point2 -> Placement
-spanLightI = spanColLightI 0.75 50.1
+--spanLightI = spanColLightI 0.75 50.1
+spanLightI = spanColLightI 0.75 95
 
 spanLightY :: Point2 -> Point2 -> Point2 -> Point2 -> Placement
 spanLightY l x y z = 
@@ -188,7 +196,7 @@ spanLightY l x y z =
         sps0 $ f z
   where
     f p = putShape $ thinHighBar h p (l + normalize (l-p))
-    h = 50
+    h = 95
 
 --extendAway :: Point2 -> Point2 -> Point2
 --extendAway p x = p +.+ squashNormalizeV (p -.- x)

src/Dodge/Placement/Instance/Sensor.hs

@@ -17,11 +17,18 @@ damageSensor dt wdth mtrid ps = pContID ps (PutLS $ lsPosCol (V3 0 0 30) 0.1) $
             PutMachine
                 (reverse $ square wdth)
                 ( defaultMachine
+                    & mcMaterial .~ mattype
                     & mcMounts . at OTTrigger .~ mtrid
                     & mcMounts . at OTLightSource ?~ lsid
                     & mcType .~ McDamSensor (DamSensor 0 dt)
                 )
                 Nothing
+  where
+    mattype = case dt of
+        LaserSensor -> Photovoltaic
+        ElectricSensor -> LightningRod
+        ThermalSensor -> Pyroelectric
+        PhysicalSensor -> Piezoelectric
 
 lightSensor :: Float -> Maybe Int -> PlacementSpot -> Placement
 lightSensor = damageSensor LaserSensor

src/Dodge/Placement/PlaceSpot.hs

@@ -27,15 +27,13 @@ import LensHelp
 import Linear
 import NewInt
 
---import System.Random
-
 -- when placing a placement, we update the world and the room and assign an id
 -- to the placement. This id should be associated with the type of placement and
 -- match up with the created id for the object (creature id, flitid id, etc)
 placeSpot :: Int -> GenWorld -> Placement -> GenWorld
 placeSpot rid w plmnt = case plmnt ^. plSpot of
     PSRoomRand i f -> placeSpotRoomRand rid i f plmnt w
-    PSPos extract eff fallback -> placeSpotUsingLink w rid plmnt extract eff fallback
+    PSPos extract eff fallback -> placeSpotUsingRoomPos w rid plmnt extract eff fallback
     _ -> placePlainPSSpot w rid plmnt shift
   where
     shift = _rmShift $ w ^?! genRooms . ix rid
@@ -64,7 +62,7 @@ placePlainPSSpot w rid plmnt shift = case plmnt ^. plType of
             (w' & genRooms . ix rid . rmPmnts .:~ newplmnt)
 
 -- this should be tidied up
-placeSpotUsingLink ::
+placeSpotUsingRoomPos ::
     GenWorld ->
     Int ->
     Placement ->
@@ -72,7 +70,7 @@ placeSpotUsingLink ::
     (RoomPos -> Room -> Room) ->
     Maybe Placement ->
     GenWorld
-placeSpotUsingLink w rid plmnt extract eff fallback =
+placeSpotUsingRoomPos w rid plmnt extract eff fallback =
     case searchedPoss (w ^?! genRooms . ix rid . rmPos) of
         Just (ps, rmposs) ->
             placeSpot
@@ -199,7 +197,7 @@ plMachine ::
 plMachine wallpoly mc mitm p rot gw =
     ( mcid
     , gw & tolw . machines . at mcid ?~ themc
-        & gwWorld %~ placeMachineWalls wallpoly mcid wlid
+        & gwWorld %~ placeMachineWalls (_mcMaterial mc) wallpoly mcid wlid
         & tolw %~ maybe id placeturretitm mitm
     )
   where
@@ -215,10 +213,11 @@ plMachine wallpoly mc mitm p rot gw =
         itid = IM.newKey $ gw ^. gwWorld . cWorld . lWorld . items
         itm' = itm & itID .~ NInt itid & itLocation .~ OnTurret mcid
 
-placeMachineWalls :: [Point2] -> Int -> Int -> World -> World
+placeMachineWalls :: Material -> [Point2] -> Int -> Int -> World -> World
-placeMachineWalls poly mcid = insertStructureWalls MachinePart baseWall poly mcid
+placeMachineWalls mat poly mcid = insertStructureWalls MachinePart baseWall poly mcid
   where
     baseWall = defaultMachineWall & wlStructure . wsMachine .~ mcid
+        & wlMaterial .~ mat
 
 mvLS :: Point3 -> Float -> LightSource -> LightSource
 mvLS (V3 x y z) rot ls = ls & lsParam . lsPos .~ V3 x y z + startPos

src/Dodge/Room/Airlock.hs

@@ -52,7 +52,7 @@ decontamRoom i =
                ]
         --        & rmOutPmnt . at i ?~
         --               analyser (NoItemZone ps) (PS 50 0) (PS mcpos 0)
-        & rmInPmnt .~ [(0, f)]
+        & rmInPmnt .~ [(0, return . f)]
         & rmBound .~ [rectNSWE 75 15 0 40, switchcut]
   where
     f gw = fromMaybe (error "tried to put a door using an empty placement list") $ do

src/Dodge/Room/Containing.hs

@@ -1,6 +1,7 @@
---{-# LANGUAGE TupleSections #-}
+-- {-# LANGUAGE TupleSections #-}
 module Dodge.Room.Containing where
 
+import Control.Monad
 import Dodge.Cleat
 import Dodge.Data.GenWorld
 import Dodge.Item.Display
@@ -15,14 +16,13 @@ import Dodge.Tree
 import Geometry
 import LensHelp
 import RandomHelp
-import Control.Monad
 
-roomsContaining :: RandomGen g => [Creature] -> [Item] -> State g (MetaTree Room String)
+roomsContaining :: (RandomGen g) => [Creature] -> [Item] -> State g (MetaTree Room String)
 roomsContaining crs its = tToBTree str <$> roomsContaining' crs its
   where
     str = "roomsContaining " ++ concatMap _crName crs ++ concatMap (head . basicItemDisplay) its
 
-roomsContaining' :: RandomGen g => [Creature] -> [Item] -> State g (Tree Room)
+roomsContaining' :: (RandomGen g) => [Creature] -> [Item] -> State g (Tree Room)
 roomsContaining' crs its = do
     endroom <-
         join $
@@ -36,7 +36,7 @@ roomsContaining' crs its = do
                 ]
     return (pure $ cleatOnward endroom)
 
-roomPillarsContaining :: RandomGen g => [Creature] -> [Item] -> State g Room
+roomPillarsContaining :: (RandomGen g) => [Creature] -> [Item] -> State g Room
 roomPillarsContaining crs itms = do
     (w, wn) <- takeOne [(240, 2), (340, 3)]
     (h, hn) <- takeOne [(240, 2), (340, 3)]
@@ -47,7 +47,7 @@ crsItmsUnused crs itms =
     map (\it -> sps0 (PutFlIt it) & plSpot .~ anyUnusedSpot) itms
         ++ map (\cr -> sps0 (PutCrit cr) & plSpot .~ unusedSpotAwayFromLink 50) crs
 
-pedestalRoom :: RandomGen g => Item -> State g Room
+pedestalRoom :: (RandomGen g) => Item -> State g Room
 pedestalRoom it = do
     let flit = PutFlIt it
     x <- state $ randomR (150, 250)

src/Dodge/Room/Door.hs

@@ -40,7 +40,7 @@ triggerDoorRoom i =
         -- note no bounds
         }
   where
-    f gw = fromMaybe (error "tried to put a door using an empty placement list") $ do
+    f gw = return $ fromMaybe (error "tried to put a door using an empty placement list") $ do
         pmnt <- gw ^? genPmnt . ix i
         return $ putDoubleDoor defaultDoorWall (cond pmnt) (V2 0 20) (V2 40 20) 2
     cond pmnt = WdTrig $ fromJust (_plMID pmnt)

src/Dodge/Room/LasTurret.hs

@@ -13,11 +13,17 @@ module Dodge.Room.LasTurret (
     lasCenRunClose',
     lasCenRunClose1,
     lasCenRunCloseLongCor,
+    lasRunRand,
+    storeRoomID,
 ) where
 
-import Data.Foldable (fold)
+import Dodge.Room.Modify
-import Dodge.Room.Path
+import Color
-import Dodge.Room.Procedural
+import Control.Monad
+import Data.Foldable
+import Data.Maybe
+-- import Data.Foldable (fold)
+
 import qualified Data.Set as S
 import Dodge.Cleat
 import Dodge.Data.GenWorld
@@ -30,6 +36,8 @@ import Dodge.Room.Corridor
 import Dodge.Room.Door
 import Dodge.Room.Link
 import Dodge.Room.Ngon
+import Dodge.Room.Path
+import Dodge.Room.Procedural
 import Dodge.Room.SensorDoor
 import Dodge.RoomLink
 import Dodge.Tree
@@ -37,47 +45,49 @@ import Dodge.Wire
 import Geometry
 import LensHelp
 import RandomHelp
+import Shape
 
+-- no lights!
 cenLasTur :: (RandomGen g) => State g Room
 cenLasTur = do
-    thelight <- mntLightLnkCond $ rprBool $ const . isInLnk
     roomNgon 8 200
         <&> rmPmnts
         .~ [ putLasTurret 0.02
            , heightWallPS
-                (resetPLUse $ rprBoolShift (const . isInLnk) (shiftInBy 100 <&> (,S.singleton UsedPosLow)))
+                (resetPLUse $ rprBoolShift (const . isInLnk) (shiftInBy 120 <&> (,S.singleton UsedPosLow)))
                 30
-                covershape
+                (rectWH 20 10)
-           , thelight
            ]
-  where
+        <&> rmPath
-    covershape = rectNSWE 10 (-10) (-20) 20
+        %~ addNodesCrossingCirc 0 30
 
 lightSensInsideDoor :: Int -> Room -> Room
-lightSensInsideDoor i rm =
+lightSensInsideDoor i =
-    rm
+    rmPmnts
-        & rmPmnts
+        .++~ [ psPt atFstLnkOut (PutForeground $ floorWire (V2 20 0) (V2 20 (-x)))
-        .++~ [ psPt atFstLnkOut (PutForeground $ floorWire (V2 20 0) (V2 20 (-100)))
+             , psPt atFstLnkOut (PutForeground $ floorWire (V2 0 (-x)) (V2 20 (-x)))
-             , psPt atFstLnkOut (PutForeground $ floorWire (V2 0 (-100)) (V2 20 (-100)))
              , psPt atFstLnkOut (PutForeground $ verticalWire (V2 20 0) 0 80)
-             , sensAboveDoor LaserSensor 10 (atFstLnkOutShiftInward 100) & plExternalID ?~ i
+             , sensAboveDoor LaserSensor 10 (atFstLnkOutShiftInward x) & plExternalID ?~ i
              ]
+  where
+    x = 120
 
 --        & rmOutPmnt . at i ?~ sensAboveDoor LaserSensor 10 (atFstLnkOutShiftInward 100)
 
-lightSensByDoor :: Int -> Room -> Room
+lightSensByDoor :: Int -> Room -> State LayoutVars Room
-lightSensByDoor i rm =
+lightSensByDoor i rm = do
+    x <- takeOne [100, 120, 140]
+    y <- takeOne [100, 110, 120]
+    sh1 <- takeOne [rectWH 20 10, square 20]
+    return $
         rm
             & rmPmnts
             .++~ [ psPt atFstLnkOut $ PutForeground $ verticalWire (V2 20 0) 0 80
-             , heightWallPS (atNthLnkOutShiftInward 1 100) 30 covershape
+                 , heightWallPS (atNthLnkOutShiftInward 1 x) 30 sh1
-             , heightWallPS (atFstLnkOutShiftInward 100) 30 covershape
+                 , heightWallPS (atFstLnkOutShiftInward y) 30 (rectWH 20 10)
                  , sensAboveDoor LaserSensor 20 (atFstLnkOutShiftBy sensorshift) & plExternalID ?~ i
                  ]
   where
-    --        & rmOutPmnt . at i ?~ sensAboveDoor LaserSensor 20 (atFstLnkOutShiftBy sensorshift)
-
-    covershape = rectNSWE 10 (-10) (-20) 20
     sensorshift (p, a) = ((p +.+ rotateV a (V2 60 (-20)), a), S.singleton UsedPosLow)
 
 keyCardRoomRunPast :: (RandomGen g) => Int -> Int -> State g (MetaTree Room String)
@@ -129,159 +139,222 @@ healthTest n = do
             , cleatOnward door
             ]
 
-lasSensorTurretTest :: (RandomGen g) => Int -> State g (MetaTree Room String)
+lasSensorTurretTest :: State LayoutVars (MetaTree Room String)
-lasSensorTurretTest n = do
+lasSensorTurretTest = do
-    cenroom <- shuffleLinks . lightSensInsideDoor n =<< cenLasTur
+    n <- nextLayoutInt
+    cenroom' <- shuffleLinks . lightSensInsideDoor n =<< cenLasTur
+    (i, cenroom'') <- storeRoomID cenroom'
+    lshape <- takeOne [vShape, lShape, jShape, liShape]
+    let alight a rp = mntLSCond (fmap (fmap $ colorSH black) lshape) (PS (rotateV a $ _rpPos rp) (a + _rpDir rp))
+    let cenroom =
+            cenroom''
+                & rmInPmnt
+                <>~ [ (0, return . alight pi . f i)
+                    , (0, return . alight (0.5 * pi) . f i)
+                    , (0, return . alight (1.5 * pi) . f i)
+                    ]
     rToOnward "lasSensorTurretTest" $
         treePost
             [door, cenroom, triggerDoorRoom n, cleatOnward door]
+  where
+    f i gw = fromJust $ find (isused . _rpType) (getRoomFromID i gw ^. rmPos)
+    isused UsedOutLink{_rplsChildNum = 0} = True
+    isused _ = False
 
-lasCenSensEdge :: (RandomGen g) => Int -> State g (MetaTree Room String)
+-- note the double usage of the int, shouldn't cause a problem
+lasCenSensEdge :: Int -> State LayoutVars (MetaTree Room String)
 lasCenSensEdge n = do
-    cenroom <- shuffleLinks . lightSensByDoor n =<< cenLasTur
+    (i, cenroom') <- storeRoomID =<< shuffleLinks =<< lightSensByDoor n =<< cenLasTur
+    lshape <- takeOne [vShape, lShape, jShape, liShape]
+    let alight a rp = mntLSCond (fmap (fmap $ colorSH black) lshape) (PS (rotateV a $ _rpPos rp) (a + _rpDir rp))
+        blight a = (0, return . alight a . f i)
+    let cenroom = cenroom' & rmInPmnt <>~ map blight [pi, (0.5 * pi), (1.5 * pi)]
     let doorroom = triggerDoorRoom n
     rToOnward "lasCenSensEdge" $
         treeFromTrunk [door] $
             Node
                 cenroom
                 [ treePost [doorroom, cleatOnward door]
-                , treePost [door, cleatLabel 0 corridor]
+                , treePost [door, cleatLabel n corridor]
                 ]
+  where
+    f i gw = fromJust $ find (isused . _rpType) (getRoomFromID i gw ^. rmPos)
+    isused UsedOutLink{_rplsChildNum = 0} = True
+    isused _ = False
+
 
 lasRunYinYang :: (RandomGen g) => State g (MetaTree Room String)
 lasRunYinYang = do
-    npoly <- takeOne [6,8,10,12]
+    npoly <- takeOne [6, 8, 10, 12]
     thelight <- mntLightLnkCond $ rprBool $ const . isInLnk
     thelight1 <- mntLightLnkCond $ rprBool $ const . isOutLnk
-    thelight2 <- mntLightLnkCond $ rprBool $ const . (\rp -> PolyEdge ((npoly + 1) `div` 4) `S.member` 
+    thelight2 <-
-        (fold $ rp ^? rpType . rplsType))
+        mntLightLnkCond $
-    thelight3 <- mntLightLnkCond $ rprBool $ const . (\rp -> PolyEdge (3*(npoly + 1) `div` 4) `S.member` 
+            rprBool $
-        (fold $ rp ^? rpType . rplsType))
+                const
-    r <- shuffleLinks =<<
+                    . ( \rp ->
-        (roomNgon npoly 250
+                            PolyEdge ((npoly + 1) `div` 4)
+                                `S.member` (fold $ rp ^? rpType . rplsType)
+                      )
+    thelight3 <-
+        mntLightLnkCond $
+            rprBool $
+                const
+                    . ( \rp ->
+                            PolyEdge (3 * (npoly + 1) `div` 4)
+                                `S.member` (fold $ rp ^? rpType . rplsType)
+                      )
+    r <-
+        shuffleLinks
+            =<< ( roomNgon npoly 250
                     <&> rmPmnts
-            .~ 
+                    .~ [angwall a | a <- [0, pi / 8 .. pi - pi / 9]]
-                [angwall a | a <- [0,pi/8..pi-pi/9]] <>
+                    <> [bngwall a | a <- [0, pi / 8 .. pi - pi / 9]]
-                [bngwall a | a <- [0,pi/8..pi-pi/9]] <>
+                    <> [ awall 0 (rectWH 15 5)
-                [ awall 0 (rectWH 15 5)
                        , putLasTurret 0.02 & plSpot . psPos .~ negate offxy
                        , putLasTurret 0.02 & plSpot . psPos .~ offxy
---                , awall (V2 0 50) (square 10)
+                       , --                , awall (V2 0 50) (square 10)
-               , thelight
+                         thelight
                        , thelight1
                        , thelight2
                        , thelight3
                        ]
-            <&> rmPath %~ (addNodesCrossingCirc 0 30
+                        <&> rmPath
-                    . flip (foldr ($)) [apath a | a <- [0,pi/8..pi-2*pi/9]]
+                        %~ ( addNodesCrossingCirc 0 30
-                    . flip (foldr ($)) [bpath a | a <- [0,pi/8..pi-2*pi/9]]
+                                . flip (foldr ($)) [apath a | a <- [0, pi / 8 .. pi - 2 * pi / 9]]
+                                . flip (foldr ($)) [bpath a | a <- [0, pi / 8 .. pi - 2 * pi / 9]]
                            )
-            <&> rmLinks %~ setInLinksByType (PolyEdge 0)
+                        <&> rmLinks
-            <&> rmLinks %~ setOutLinksByType (PolyEdge (npoly `div` 2))
+                        %~ setInLinksByType (PolyEdge 0)
+                        <&> rmLinks
+                        %~ setOutLinksByType (PolyEdge (npoly `div` 2))
                 )
     rToOnward "lasCenRunClose" $ return $ cleatOnward r
   where
     awall x v = heightWallPS (PS x 0) 30 v
-    --angwall a = awall (V2 0 100 + rotateV a (V2 0 100)) (fmap (rotateV (pi/4 + a/2)) $ rectWH 5 (25 - a*10/pi ))
+    -- angwall a = awall (V2 0 100 + rotateV a (V2 0 100)) (fmap (rotateV (pi/4 + a/2)) $ rectWH 5 (25 - a*10/pi ))
     rf = 0.8
     offxy = V2 0 (-100)
-    angwall a = awall (V2 0 100 + rotateV a (V2 0 100)) (fmap (rotateV (pi/4 + a*rf)) $ rectWH 5 (23 - a*13/pi ))
+    angwall a = awall (V2 0 100 + rotateV a (V2 0 100)) (fmap (rotateV (pi / 4 + a * rf)) $ rectWH 5 (23 - a * 13 / pi))
-    apath a' = addNodesCrossing $ (\x -> (x + f (V2 0 100),x - f (V2 0 100))) (V2 0 100 + rotateV a (V2 0 100))
+    apath a' = addNodesCrossing $ (\x -> (x + f (V2 0 100), x - f (V2 0 100))) (V2 0 100 + rotateV a (V2 0 100))
       where
-        a = a' + pi/16
+        a = a' + pi / 16
-        f = rotateV (pi/4 + a *0.8)
+        f = rotateV (pi / 4 + a * 0.8)
-    bngwall a = awall (V2 0 (-100) + rotateV a (V2 0 (-100))) (fmap (rotateV (pi/4 + a*rf)) $ rectWH 5 (23 - a*13/pi ))
+    bngwall a = awall (V2 0 (-100) + rotateV a (V2 0 (-100))) (fmap (rotateV (pi / 4 + a * rf)) $ rectWH 5 (23 - a * 13 / pi))
-    bpath a' = addNodesCrossing $ (\x -> (x + f (V2 0 100),x - f (V2 0 100))) (V2 0 (-100) + rotateV a (V2 0 (-100)))
+    bpath a' = addNodesCrossing $ (\x -> (x + f (V2 0 100), x - f (V2 0 100))) (V2 0 (-100) + rotateV a (V2 0 (-100)))
       where
-        a = a' + pi/16
+        a = a' + pi / 16
-        f = rotateV (pi/4 + a *0.8)
+        f = rotateV (pi / 4 + a * 0.8)
 
 lasRunYinYangCenter :: (RandomGen g) => State g (MetaTree Room String)
 lasRunYinYangCenter = do
-    npoly <- takeOne [6,8,10,12]
+    npoly <- takeOne [6, 8, 10, 12]
     thelight <- mntLightLnkCond $ rprBool $ const . isInLnk
     thelight1 <- mntLightLnkCond $ rprBool $ const . isOutLnk
-    thelight2 <- mntLightLnkCond $ rprBool $ const . (\rp -> PolyEdge ((npoly + 1) `div` 4) `S.member` 
+    thelight2 <-
-        (fold $ rp ^? rpType . rplsType))
+        mntLightLnkCond $
-    thelight3 <- mntLightLnkCond $ rprBool $ const . (\rp -> PolyEdge (3*(npoly + 1) `div` 4) `S.member` 
+            rprBool $
-        (fold $ rp ^? rpType . rplsType))
+                const
---    thelight3 <- mntLightLnkCond $ rprBool $ const . isOutLnk
+                    . ( \rp ->
-    r <- shuffleLinks =<<
+                            PolyEdge ((npoly + 1) `div` 4)
-        (roomNgon npoly 250
+                                `S.member` (fold $ rp ^? rpType . rplsType)
+                      )
+    thelight3 <-
+        mntLightLnkCond $
+            rprBool $
+                const
+                    . ( \rp ->
+                            PolyEdge (3 * (npoly + 1) `div` 4)
+                                `S.member` (fold $ rp ^? rpType . rplsType)
+                      )
+    --    thelight3 <- mntLightLnkCond $ rprBool $ const . isOutLnk
+    r <-
+        shuffleLinks
+            =<< ( roomNgon npoly 250
                     <&> rmPmnts
-            .~ 
+                    .~ [angwall a | a <- [0, pi / 8 .. pi - pi / 9]]
-                [angwall a | a <- [0,pi/8..pi-pi/9]] <>
+                    <> [bngwall a | a <- [0, pi / 8 .. pi - pi / 9]]
-                [bngwall a | a <- [0,pi/8..pi-pi/9]] <>
+                    <> [ putLasTurret 0.02
-                [ putLasTurret 0.02
+                       , --                , awall (V2 0 50) (square 10)
---                , awall (V2 0 50) (square 10)
+                         thelight
-               , thelight
                        , thelight1
                        , thelight2
                        , thelight3
                        ]
-            <&> rmPath %~ (addNodesCrossingCirc 0 30
+                        <&> rmPath
-                    . flip (foldr ($)) [apath a | a <- [0,pi/8..pi-2*pi/9]]
+                        %~ ( addNodesCrossingCirc 0 30
-                    . flip (foldr ($)) [bpath a | a <- [0,pi/8..pi-2*pi/9]]
+                                . flip (foldr ($)) [apath a | a <- [0, pi / 8 .. pi - 2 * pi / 9]]
+                                . flip (foldr ($)) [bpath a | a <- [0, pi / 8 .. pi - 2 * pi / 9]]
                            )
-            <&> rmLinks %~ setInLinksByType (PolyEdge 0)
+                        <&> rmLinks
-            <&> rmLinks %~ setOutLinksByType (PolyEdge (npoly `div` 2))
+                        %~ setInLinksByType (PolyEdge 0)
+                        <&> rmLinks
+                        %~ setOutLinksByType (PolyEdge (npoly `div` 2))
                 )
     rToOnward "lasCenRunClose" $ return $ cleatOnward r
   where
     awall x v = heightWallPS (PS x 0) 30 v
-    --angwall a = awall (V2 0 100 + rotateV a (V2 0 100)) (fmap (rotateV (pi/4 + a/2)) $ rectWH 5 (25 - a*10/pi ))
+    -- angwall a = awall (V2 0 100 + rotateV a (V2 0 100)) (fmap (rotateV (pi/4 + a/2)) $ rectWH 5 (25 - a*10/pi ))
-    angwall a = awall (V2 0 100 + rotateV a (V2 0 100)) (fmap (rotateV (pi/4 + a*0.8)) $ rectWH 5 (23 - a*13/pi ))
+    angwall a = awall (V2 0 100 + rotateV a (V2 0 100)) (fmap (rotateV (pi / 4 + a * 0.8)) $ rectWH 5 (23 - a * 13 / pi))
-    apath a' = addNodesCrossing $ (\x -> (x + f (V2 0 100),x - f (V2 0 100))) (V2 0 100 + rotateV a (V2 0 100))
+    apath a' = addNodesCrossing $ (\x -> (x + f (V2 0 100), x - f (V2 0 100))) (V2 0 100 + rotateV a (V2 0 100))
       where
-        a = a' + pi/16
+        a = a' + pi / 16
-        f = rotateV (pi/4 + a *0.8)
+        f = rotateV (pi / 4 + a * 0.8)
-    bngwall a = awall (V2 0 (-100) + rotateV a (V2 0 (-100))) (fmap (rotateV (pi/4 + a*0.8)) $ rectWH 5 (23 - a*13/pi ))
+    bngwall a = awall (V2 0 (-100) + rotateV a (V2 0 (-100))) (fmap (rotateV (pi / 4 + a * 0.8)) $ rectWH 5 (23 - a * 13 / pi))
-    bpath a' = addNodesCrossing $ (\x -> (x + f (V2 0 100),x - f (V2 0 100))) (V2 0 (-100) + rotateV a (V2 0 (-100)))
+    bpath a' = addNodesCrossing $ (\x -> (x + f (V2 0 100), x - f (V2 0 100))) (V2 0 (-100) + rotateV a (V2 0 (-100)))
       where
-        a = a' + pi/16
+        a = a' + pi / 16
-        f = rotateV (pi/4 + a *0.8)
+        f = rotateV (pi / 4 + a * 0.8)
 
 lasCenRunClose' :: (RandomGen g) => State g (MetaTree Room String)
 lasCenRunClose' = do
-    npoly <- takeOne [5..12]
+    npoly <- takeOne [5 .. 12]
     inwall <- takeOne obwalls
     outwall <- takeOne obwalls
     thelight <- mntLightLnkCond $ rprBool $ const . isInLnk
     thelight1 <- mntLightLnkCond $ rprBool $ const . isOutLnk
-    r <- shuffleLinks =<<
+    r <-
-        (roomNgon npoly 250
+        shuffleLinks
+            =<< ( roomNgon npoly 250
                     <&> rmPmnts
-            .~ (
+                    .~ ( fmap (uncurry inlinkwall) inwall
-                 fmap (uncurry inlinkwall) inwall <>
+                            <> fmap (uncurry outlinkwall) outwall
-                 fmap (uncurry outlinkwall) outwall <>
+                            <> [ putLasTurret 0.02
-                [ putLasTurret 0.02
                                , thelight
                                , thelight1
                                ]
                        )
-            <&> rmPath %~ addNodesCrossingCirc 0 30
+                    <&> rmPath
-            <&> rmLinks %~ setInLinksByType (PolyEdge 0)
+                    %~ addNodesCrossingCirc 0 30
-            <&> rmLinks %~ setOutLinks (\rl -> or [PolyEdge i `S.member` _rlType rl | i <- [2..npoly-2]])
+                    <&> rmLinks
+                    %~ setInLinksByType (PolyEdge 0)
+                    <&> rmLinks
+                    %~ setOutLinks (\rl -> or [PolyEdge i `S.member` _rlType rl | i <- [2 .. npoly - 2]])
                 )
     rToOnward "lasCenRunClose" $ return $ cleatOnward r
   where
-    swall = [ (70, (rectNSWE 10 (-10) (-10) 30))
+    swall =
+        [ (70, (rectNSWE 10 (-10) (-10) 30))
         , (125, (rectNSWE 55 (-55) (-10) 10))
         , (180, (rectNSWE 10 (-10) (-30) 10))
         ]
-    zwall = [ (70, (rectNSWE 10 (-10) (-30) 10))
+    zwall =
+        [ (70, (rectNSWE 10 (-10) (-30) 10))
         , (125, (rectNSWE 55 (-55) (-10) 10))
         , (180, (rectNSWE 10 (-10) (-10) 30))
         ]
-    iwall = [ (70, (rectNSWE 10 (-10) (-15) 20))
+    iwall =
+        [ (70, (rectNSWE 10 (-10) (-15) 20))
         , (180, (rectNSWE 10 (-10) (-30) (-5)))
         ]
-    jwall = [ (70, (rectNSWE 10 (-10) (-20) 15))
+    jwall =
+        [ (70, (rectNSWE 10 (-10) (-20) 15))
         , (180, (rectNSWE 10 (-10) 5 30))
         ]
-    uwall = [ (180, (rectNSWE 10 (-10) (-20) 20)) ]
+    uwall = [(180, (rectNSWE 10 (-10) (-20) 20))]
-    obwalls = [swall,zwall,iwall,jwall,uwall]
+    obwalls = [swall, zwall, iwall, jwall, uwall]
-    linkwall f x = heightWallPS
+    linkwall f x =
+        heightWallPS
             (resetPLUse $ rprBoolShift (const . f) (shiftInBy x <&> (,S.singleton UsedPosLow)))
             30
     inlinkwall = linkwall isInLnk
@@ -289,52 +362,64 @@ lasCenRunClose' = do
 
 lasCenRunCloseLongCor :: (RandomGen g) => State g (MetaTree Room String)
 lasCenRunCloseLongCor = do
-    (alinks,blinks) <- shufflePair (rlinks,llinks)
+    (alinks, blinks) <- shufflePair (rlinks, llinks)
-    rdir <- takeOne [negate,id]
+    rdir <- takeOne [negate, id]
-    a <- takeOne [5*pi/16]
+    a <- takeOne [5 * pi / 16]
     let h = 800
-    laspos <- takeOne [V2 (h/2) 80]
+    laspos <- takeOne [V2 (h / 2) 80]
-    ls <- mntLightLnkCond (PS (V2 (h/2) 0) pi)
+    ls <- mntLightLnkCond (PS (V2 (h / 2) 0) pi)
-    r <- shuffleLinks =<<
+    r <-
-        (roomRectAutoLights h 160
+        shuffleLinks
+            =<< ( roomRectAutoLights h 160
                     <&> rmPmnts
                     <>~ [ putLasTurret 0.02 & plSpot .~ PS laspos a
-               , awall (V2 (h /4) 80) (rotateV (rdir pi/16) <$> rectWH 180 10) 
+                        , awall (V2 (h / 4) 80) (rotateV (rdir pi / 16) <$> rectWH 180 10)
-               , awall (V2 (3*h/4) 80) (rotateV (rdir pi/16) <$> rectWH 180 10)
+                        , awall (V2 (3 * h / 4) 80) (rotateV (rdir pi / 16) <$> rectWH 180 10)
                         , ls
                         ]
-            <&> rmLinks %~ setInLinks alinks
+                    <&> rmLinks
-            <&> rmLinks %~ setOutLinks blinks
+                    %~ setInLinks alinks
-            <&> rmPath %~ 
+                    <&> rmLinks
-                (addNodesCrossing (V2 (h/2-10) 30,V2 (h/2+50) 90) 
+                    %~ setOutLinks blinks
-                .addNodesCrossing (V2 (h/2+10) 130,V2 (h/2-50) 70) )
+                    <&> rmPath
+                    %~ ( addNodesCrossing (V2 (h / 2 - 10) 30, V2 (h / 2 + 50) 90)
+                            . addNodesCrossing (V2 (h / 2 + 10) 130, V2 (h / 2 - 50) 70)
+                       )
                 )
     rToOnward "lasCenRunClose" $ return $ cleatOnward r
   where
     llinks = memtest (FromEdge South 1) (OnEdge West)
     rlinks = memtest (FromEdge South 1) (OnEdge East)
     awall x v = heightWallPS (PS x 0) 30 v
-    etest f g x = f x || g x
+    memtest a b x =
-    memtest a b x = let y = _rlType x
+        let y = _rlType x
          in a `S.member` y && b `S.member` y
 
 lasCenRunClose1 :: (RandomGen g) => State g (MetaTree Room String)
 lasCenRunClose1 = do
-    --(alinks,blinks) <- shufflePair (bllinks,brlinks)
+    -- (alinks,blinks) <- shufflePair (bllinks,brlinks)
-    --(alinks,blinks) <- shufflePair (bllinks,tmllink)
+    -- (alinks,blinks) <- shufflePair (bllinks,tmllink)
-    lnks <- shuffle [bllinks,brlinks,tmllink,tmrlink]
+    lnks <- shuffle [bllinks, brlinks, tmllink, tmrlink]
     let alinks = lnks !! 0
         blinks = lnks !! 1
-    outwall <- takeOne [awall (V2 185 25) (rectWH 10 50) 
+    outwall <-
-               , awall (V2 200 50) (rectWH 50 10) ]
+        takeOne
+            [ awall (V2 185 25) (rectWH 10 50)
+            , awall (V2 200 50) (rectWH 50 10)
+            ]
     let z = 35
-    r <- roomRectAutoLights 250 200
+    r <-
-            <&> rmPolys .~ [[V2 0 0, V2 250 0
+        roomRectAutoLights 250 200
-                , V2 250 (200-z)
+            <&> rmPolys
+            .~ [
+                   [ V2 0 0
+                   , V2 250 0
+                   , V2 250 (200 - z)
                    , V2 (250 - z) 200
                    , V2 z 200
-                , V2 0 (200-z)
+                   , V2 0 (200 - z)
-                ]]
+                   ]
+               ]
             <&> rmPmnts
             <>~ [ putLasTurret 0.02 & plSpot .~ PS (V2 125 100) 0
                 , awall (V2 65 25) (rectWH 10 50)
@@ -342,62 +427,83 @@ lasCenRunClose1 = do
                 , awall (V2 95 150) (rectWH 10 20)
                 , awall (V2 155 150) (rectWH 10 20)
                 , sps0 $ putConvexChasm $ rectNSWE 200 110 105 145
---               , awall (V2 150 215) (rectWH 60 10)
+                --               , awall (V2 150 215) (rectWH 60 10)
                 ]
-            <&> rmLinks %~ setInLinks alinks
+            <&> rmLinks
---            <&> rmLinks %~ setOutLinks (memtest (OnEdge South) (FromEdge West 3))
+            %~ setInLinks alinks
-            <&> rmLinks %~ setOutLinks blinks
+            --            <&> rmLinks %~ setOutLinks (memtest (OnEdge South) (FromEdge West 3))
-            <&> rmLinks . each %~ mvlinks
+            <&> rmLinks
-            <&> rmPath %~ S.map (both %~ mvpath)
+            %~ setOutLinks blinks
+            <&> rmLinks
+            . each
+            %~ mvlinks
+            <&> rmPath
+            %~ S.map (both %~ mvpath)
     rToOnward "lasCenRunClose" $ return $ cleatOnward r
   where
-    mvlinks lnk | tmllink lnk = lnk & rlPos -~ V2 20 0
+    mvlinks lnk
+        | tmllink lnk = lnk & rlPos -~ V2 20 0
         | tmrlink lnk = lnk & rlPos +~ V2 20 0
         | otherwise = lnk
-    mvpath (V2 x y) | y > 190 , x > 50 , x < 125 = V2 (x- 20) y
+    mvpath (V2 x y)
-        | y > 190 , x > 125 , x < 200 = V2 (x+ 20) y
+        | y > 190, x > 50, x < 125 = V2 (x - 20) y
+        | y > 190, x > 125, x < 200 = V2 (x + 20) y
         | otherwise = V2 x y
     tmllink = memtest (FromEdge West 1) (OnEdge North)
     tmrlink = memtest (FromEdge West 2) (OnEdge North)
-    bllinks = etest 
+    bllinks =
+        etest
             (memtest (FromEdge West 0) (OnEdge South))
             (memtest (FromEdge South 0) (OnEdge West))
-    brlinks = etest
+    brlinks =
+        etest
             (memtest (FromEdge East 0) (OnEdge South))
             (memtest (FromEdge South 0) (OnEdge East))
     awall x v = heightWallPS (PS x 0) 30 v
     etest f g x = f x || g x
-    memtest a b x = let y = _rlType x
+    memtest a b x =
+        let y = _rlType x
          in a `S.member` y && b `S.member` y
 
+lasRunRand :: (RandomGen g) => State g (MetaTree Room String)
+lasRunRand = join $ takeOne [lasCenRunClose2, lasCenRunClose1]
+
 lasCenRunClose2 :: (RandomGen g) => State g (MetaTree Room String)
 lasCenRunClose2 = do
-    (alinks,blinks) <- shufflePair (bllinks,trlinks)
+    (alinks, blinks) <- shufflePair (bllinks, trlinks)
-    a <- takeOne [3*pi/2,3*pi/4]
+    a <- takeOne [3 * pi / 2, 3 * pi / 4]
     laspos <- takeOne [V2 60 190, V2 65 185]
-    r <- shuffleLinks =<<
+    r <-
-        (roomRectAutoLights 250 250
+        shuffleLinks
+            =<< ( roomRectAutoLights 250 250
                     <&> rmPmnts
                     <>~ [ putLasTurret 0.02 & plSpot .~ PS laspos a
                         , awall (V2 35 100) (rectWH 10 60)
                         , awall (V2 150 215) (rectWH 60 10)
                         ]
-            <&> rmLinks %~ setInLinks alinks
+                    <&> rmLinks
-            <&> rmLinks %~ setOutLinks blinks
+                    %~ setInLinks alinks
-            <&> rmPath %~ (addNodesCrossing (V2 110 170,V2 30 250) 
+                    <&> rmLinks
-                .addNodesCrossing (V2 70 150,V2 10 210) )
+                    %~ setOutLinks blinks
+                    <&> rmPath
+                    %~ ( addNodesCrossing (V2 110 170, V2 30 250)
+                            . addNodesCrossing (V2 70 150, V2 10 210)
+                       )
                 )
     rToOnward "lasCenRunClose" $ return $ cleatOnward r
   where
-    bllinks = etest 
+    bllinks =
+        etest
             (memtest (FromEdge West 0) (OnEdge South))
             (memtest (FromEdge South 0) (OnEdge West))
-    trlinks = etest
+    trlinks =
+        etest
             (memtest (FromEdge East 0) (OnEdge North))
             (memtest (FromEdge North 0) (OnEdge East))
     awall x v = heightWallPS (PS x 0) 30 v
     etest f g x = f x || g x
-    memtest a b x = let y = _rlType x
+    memtest a b x =
+        let y = _rlType x
          in a `S.member` y && b `S.member` y
 
 lasTunnel :: (RandomGen g) => Float -> State g Room

src/Dodge/Room/Modify.hs

@@ -1,4 +1,76 @@
-module Dodge.Room.Modify 
+module Dodge.Room.Modify (
-    ( module Dodge.Room.Modify.Girder
+    module Dodge.Room.Modify.Girder,
-    ) where
+    storeRoomID,
+    getRoomFromID,
+    addLightsNGon,
+    removeLights,
+) where
+
+import Color
+import Shape
+import Dodge.Placement.Instance.LightSource
+import Dodge.LevelGen.PlacementHelper
+import LensHelp
+import Dodge.Data.MetaTree
+import RandomHelp
+import Dodge.Data.GenWorld
 import Dodge.Room.Modify.Girder
+import qualified Data.Set as S
+import Data.Maybe
+import Geometry
+import Data.Foldable
+
+storeRoomID :: Room -> State LayoutVars (Int, Room)
+storeRoomID x = do
+    i <- nextLayoutInt
+    return (i, x & rmPmnts .:~ sps0 (PutWorldUpdate (f i)))
+  where
+    f i rid _ gw = gw & genInts . at i ?~ (gw ^?! genRooms . ix rid . rmMID . _Just)
+
+-- unsafe! assumes that storeRoomID has been called
+getRoomFromID :: Int -> GenWorld -> Room
+getRoomFromID i gw = gw ^?! genRooms . ix (gw ^?! genInts . ix i)
+
+removeLights :: Room -> Room
+removeLights = rmPmnts %~ mapMaybe f
+  where
+    f x = case x ^. plType of
+        PutLabel "light" -> Nothing
+        _ -> Just x
+
+addLightsNGon :: Room -> State LayoutVars Room
+addLightsNGon rm = do
+    (i, rm') <- storeRoomID $ removeLights rm
+    return $
+        rm'
+            & rmInPmnt
+            .:~ (0, f i)
+  where
+    a = 2 * pi - (2 * pi / fromIntegral (rm ^?! rmType . rmngonSides))
+    y = rm ^?! rmType . rmngonSize
+    x = y * tan (0.5 * a)
+    f i gw = do
+        lshape <- takeOne [vShape, lShape, jShape, liShape]
+        let ps = fromMaybe (PS (V2 y 0) 0) $ rpToPS <$> find iscolorlight (grm ^. rmPos)
+            alight a' = mntLSCond (fmap (fmap $ colorSH black) lshape) (rotateps a' ps)
+        takeOne
+            [ spanLightY (V2 0 0) (V2 y x) (V2 (x) y) (V2 (x) (-y))
+            , spanLightY (V2 20 20) (V2 y 20) (V2 (-y) 20) (V2 20 (-y))
+            , spanLightI (V2 22 y) (V2 22 (-y))
+            , spanLightI (V2 x y) (V2 (-x) (-y))
+            , alight (0.5 * pi) <> alight (1.5 * pi)
+            ]
+      where
+        grm = getRoomFromID i gw
+    rotateps a' (PS v d) = PS (rotateV a' v) (a' + d)
+    rotateps _ _ = error "in addLightsNGon"
+    rpToPS rp = (PS (_rpPos rp) (_rpDir rp))
+    iscolorlight rp =
+        (ColoredLightRP `S.member` (rp ^. rpFlags))
+            && islinkroompos rp
+    islinkroompos rp = case rp ^. rpType of
+        UsedOutLink{} -> True
+        UsedInLink{} -> True
+        UnusedLink{} -> True
+        NotLink{} -> False
+

src/Dodge/Room/Ngon.hs

@@ -24,6 +24,7 @@ roomNgon n x = do
             , _rmPmnts = [thelight]
             , _rmBound = [poly]
             , _rmFloor = Tiled [makeTileFromPoly poly 2]
+            , _rmType = RoomNgon n x
             --, _rmFloor = InheritFloor
             , _rmName = show n ++ "gon"
             , _rmPos = poss

src/Dodge/Room/Procedural.hs

@@ -118,8 +118,9 @@ gridRoomPos xs ys = map makeonpos (grid xs ys) <> map makeoffpos (grid (mids xs)
 -- to do so)
 roomRectAutoLights :: RandomGen g => Float -> Float -> State g Room
 roomRectAutoLights x y = do
-    l1 <- mntLightLnkCond $ resetPLUse $ rprBool $ \rp _ -> isInLnk rp   
+    shp <- takeOne [vShape, lShape, jShape, liShape]
-    l2 <- mntLightLnkCond $ resetPLUse $ rprBool $ \rp _ -> isOutLnk rp
+    let l1 = mntLightLnkShape shp $ resetPLUse $ rprBool $ \rp _ -> isInLnk rp   
+        l2 = mntLightLnkShape shp $ resetPLUse $ rprBool $ \rp _ -> isOutLnk rp
     return $ roomRect x y (f x) (f y)
         & rmName .~ "autoRect"
         & rmPmnts .~ [ l1 , l2 ]

src/Dodge/Room/Room.hs

@@ -15,6 +15,7 @@ module Dodge.Room.Room (
     critDeadEnd,
 ) where
 
+import Data.Maybe
 import Linear
 import Color
 import Dodge.Placement.Instance.Pipe
@@ -154,7 +155,7 @@ roomCenterPillar = do
                             roomRect 240 240 2 2
             )
 
-weaponEmptyRoom :: State StdGen (Tree Room)
+weaponEmptyRoom :: RandomGen g => State g (Tree Room)
 weaponEmptyRoom = do
     w <- state $ randomR (220, 300)
     h <- state $ randomR (220, 300)
@@ -209,7 +210,7 @@ weaponBehindPillar = do
             , cleatOnward $ set rmPmnts [sPS (V2 20 60) (negate $ pi / 2) randC1] corridorN
             ]
 
-weaponBetweenPillars :: State StdGen (MetaTree Room String)
+weaponBetweenPillars :: State LayoutVars (MetaTree Room String)
 weaponBetweenPillars = do
     (w, wn) <- takeOne [(240, 2), (340, 3)]
     (h, hn) <- takeOne [(240, 2), (340, 3)]
@@ -271,7 +272,7 @@ deadEndRoom =
     lnks = [(V2 0 30, 0)]
 
 {- A random Either tree with a weapon and melee monster challenge.  -}
-weaponRoom :: State StdGen (MetaTree Room String)
+weaponRoom :: State LayoutVars (MetaTree Room String)
 weaponRoom =
     join $
         takeOne
@@ -428,8 +429,8 @@ distributerRoom :: AmmoType -> Int -> State LayoutVars Room
 distributerRoom atype aamount = do
     i <- nextLayoutInt
     i1 <- nextLayoutInt
-    w <- state $ randomR (100, 400)
+    w <- state $ randomR (100, 200)
-    h <- state $ randomR (200, 400)
+    h <- state $ randomR (200, 200)
     r <- roomRectAutoLights w h
     let mcstore = defaultMachine
             & mcMaterial .~ Metal
@@ -446,8 +447,8 @@ distributerRoom atype aamount = do
                     & plSpot .~ unusedOffPathAwayFromLink 50
                     & plExternalID ?~ i1
         thepipe gw = 
-            let p1 = gw ^?! genPmnt . ix i . plSpot . psPos
+            let p1 = fromMaybe (error "distributerRoom pipe") $ gw ^? genPmnt . ix i . plSpot . psPos
-                p2 = gw ^?! genPmnt . ix i1 . plSpot . psPos
+                p2 = fromMaybe (error "distributerRoom pipe") $ gw ^? genPmnt . ix i1 . plSpot . psPos
             in sps (PS p1 0) 
                 (PutForeground 
                     (ForegroundShape 0 0 
@@ -458,7 +459,7 @@ distributerRoom atype aamount = do
                     )
                 )
     return $ r & rmPmnts .:~ store
-        & rmInPmnt <>~ [(0,dst),(1,thepipe)]
+        & rmInPmnt <>~ [(0,return . dst),(1,return . thepipe)]
         & rmLinks %~ setInLinksByType (OnEdge South)
         & rmLinks %~ setOutLinks (not . S.member (OnEdge South) . _rlType)
 

src/Dodge/Room/SensorDoor.hs

@@ -1,33 +1,42 @@
 {-# LANGUAGE TupleSections #-}
-module Dodge.Room.SensorDoor (sensAboveDoor,sensorRoomRunPast) where
 
-import Dodge.Data.MTRS
+module Dodge.Room.SensorDoor (sensAboveDoor, sensorRoomRunPast) where
+
+import Control.Monad
 import qualified Data.Set as S
 import Dodge.Cleat
 import Dodge.Data.GenWorld
+import Dodge.Data.MTRS
 import Dodge.LevelGen.PlacementHelper
 import Dodge.Placement.Instance
 import Dodge.PlacementSpot
 import Dodge.Room.Corridor
 import Dodge.Room.Door
 import Dodge.Room.Link
+import Dodge.Room.Modify
 import Dodge.Room.Ngon
 import Dodge.Room.Procedural
+import Dodge.RoomLink
 import Dodge.Terminal
 import Dodge.Tree
 import Dodge.Wire
 import Geometry
 import LensHelp
 import RandomHelp
-import Control.Monad
 
 -- TODO fix case where the sensor created by sensInsideDoor blocks another door
 -- for roomRectAutoLinks-- make the locked door a center door?
-sensorRoom :: RandomGen g => SensorType -> Int -> State g (Tree Room)
+sensorRoom :: SensorType -> Int -> State LayoutVars (Tree Room)
 sensorRoom senseType n = do
-    rm <- join $ takeOne [roomNgon 8 200, roomRectAutoLights 200 200]
+    rm <-
+        join $
+            takeOne
+                [ addLightsNGon =<< roomNgon 8 200
+                , roomRectAutoLights 200 200 <&> rmLinks %~ setOutLinks nonCornerLinks
+                ]
     cenroom <- shuffleLinks $ sensInsideDoor senseType n rm
-    return $ treePost
+    return $
+        treePost
             [ door
             , cenroom & rmLinkEff .~ f
             , triggerDoorRoom n
@@ -43,29 +52,51 @@ sensorRoom senseType n = do
         p' = p +.+ rotateV d (V2 0 (negate 100))
         isclose = dist (_rlPos rl) p' < 30
 
-sensorRoomRunPast :: RandomGen g => SensorType -> Int -> State g MTRS
+nonCornerLinks :: RoomLink -> Bool
+nonCornerLinks = not . any f . (^. rlType)
+  where
+    f (FromEdge _ 0) = True
+    f _ = False
+
+sensorRoomRunPast :: SensorType -> Int -> State LayoutVars MTRS
 sensorRoomRunPast dt n = do
     t <- sensorRoom dt n
-    rToOnward "sensorRoomRunPast" $ t
+    rToOnward "sensorRoomRunPast" $
-            & applyToSubforest [0]
+        t
-                ( ++ [ treePost [ door & rmConnectsTo .~ (\s -> S.member InLink s && not (S.member BlockedLink s)) , cleatLabel n corridor ] ])
+            & applyToSubforest
+                [0]
+                (++ [treePost [door & rmConnectsTo .~ (\s -> S.member InLink s && not (S.member BlockedLink s)), cleatLabel n corridor]])
 
 sensAboveDoor :: SensorType -> Float -> PlacementSpot -> Placement
 sensAboveDoor sensetype wth ps =
     extTrigLitPos
+        ( psposAddLabel
+            ColoredLightRP
             (atFstLnkOutShiftBy (\(p, a) -> ((p +.+ rotateV a (V2 18.5 (-2.5)), a), S.singleton UsedPosHigh)))
+        )
         (\tp -> Just $ damageSensor sensetype wth (_plMID tp) ps)
 
 sensInsideDoor :: SensorType -> Int -> Room -> Room
-sensInsideDoor senseType i rm = rm
+sensInsideDoor senseType i rm =
-    & rmName .++~ take 4 (show senseType)
+    rm
+        & rmName
+        .++~ take 4 (show senseType)
         & rmPmnts
         .++~ [ psPt atFstLnkOut . PutForeground $ floorWire (V2 20 0) (V2 20 (-100))
              , psPt atFstLnkOut . PutForeground $ floorWire (V2 0 (-100)) (V2 20 (-100))
              , psPt atFstLnkOut . PutForeground $ verticalWire (V2 20 0) 0 80
              , putMessageTerminal
                 (textTerminal & tmCommands .:~ TCDamageCommand)
-                & plSpot .~ rprBoolShift isUnusedLnk (shiftInBy 10 <&> (, S.singleton UsedPosHigh))
+                & plSpot
+                .~ rprBoolShift termpos (shiftInBy 10 <&> (,S.singleton UsedPosHigh))
              , sensAboveDoor senseType 10 (atFstLnkOutShiftInward 100) & plExternalID ?~ i
              ]
---    & rmOutPmnt . at i ?~ sensAboveDoor senseType 10 (atFstLnkOutShiftInward 100)
+  where
+    termpos rp rm' =
+        isUnusedLnk rp rm'
+            && all ((> 30) . dist (_rpPos rp) . _rpPos) (filter usedlnks $ rm' ^. rmPos)
+    usedlnks rp = case _rpType rp of
+        UsedOutLink{} -> True
+        UsedInLink{} -> True
+        UnusedLink{} -> False
+        NotLink{} -> False

src/Dodge/Room/Start.hs

@@ -50,8 +50,9 @@ powerFakeout = do
                    ]
 
 -- the i is used either for a PickOnePlacement or a room id, this is not great
-startRoom :: Int -> State StdGen (MetaTree Room String)
+startRoom :: State LayoutVars (MetaTree Room String)
-startRoom i =
+startRoom = do
+    i <- nextLayoutInt
     join $
         takeOne
             [ attachOnward "startThenWeaponRoom" <$> preCritStart <*> weaponRoom

src/Dodge/Room/Tutorial.hs

@@ -1,42 +1,43 @@
 {-# OPTIONS_GHC -Wno-unused-imports #-}
+
 module Dodge.Room.Tutorial where
 
-import Data.Maybe
-import Dodge.LockAndKey
-import Dodge.Room.SensorDoor
-import Dodge.Room.Room
-import Dodge.Data.AmmoType
-import Dodge.Room.Path
-import Dodge.Room.Pillar
-import Dodge.Room.Boss
-import Dodge.Room.Tanks
-import Dodge.Room.LongDoor
-import Dodge.Layout
-import Dodge.Item.Held.Utility
 import Control.Monad
 import qualified Data.IntMap.Strict as IM
 import qualified Data.IntSet as IS
+import Data.Maybe
 import Data.Maybe (mapMaybe)
 import qualified Data.Set as S
 import Dodge.Cleat
+import Dodge.Data.AmmoType
 import Dodge.Data.GenWorld
 import Dodge.Data.MTRS
 import Dodge.Default.Terminal
 import Dodge.Item.Ammo
 import Dodge.Item.Held.Cane
+import Dodge.Item.Held.Utility
+import Dodge.Layout
 import Dodge.LevelGen.PlacementHelper
+import Dodge.LockAndKey
 import Dodge.Placement.Instance
 import Dodge.PlacementSpot
 import Dodge.Room.Airlock
+import Dodge.Room.Boss
 import Dodge.Room.Corridor
 import Dodge.Room.Door
 import Dodge.Room.LasTurret
 import Dodge.Room.Link
+import Dodge.Room.LongDoor
+import Dodge.Room.Modify
 import Dodge.Room.Ngon
+import Dodge.Room.Path
+import Dodge.Room.Pillar
 import Dodge.Room.Procedural
 import Dodge.Room.RezBox
 import Dodge.Room.RoadBlock
 import Dodge.Room.Room
+import Dodge.Room.SensorDoor
+import Dodge.Room.Tanks
 import Dodge.Room.Warning
 import Dodge.RoomLink
 import Dodge.Terminal
@@ -52,45 +53,32 @@ tutAnoTree :: State LayoutVars MTRS
 tutAnoTree = do
     foldMTRS
         [ tToBTree "TutStartRez" . return . cleatOnward <$> tutRezBox
---        , return . tToBTree "door" $ treePost [corridor, cleatOnward door]
         , corDoor
---        , tToBTree "cor" . return <$> shuffleLinks (cleatOnward corridor)
+        , chasmSpitTerminal
-        , lasRunYinYang
+        , return $ tToBTree "cor" $ return $ cleatOnward corridor
---        , passthroughLockKeyLists lockRoomKeyItems itemRooms
+        , corDoor
-        , tToBTree "door" . return <$> return (cleatOnward door)
+        , tToBTree "sdr" . return . cleatOnward
-        , tToBTree "cor" . return <$> shuffleLinks (cleatOnward corridor)
+            <$> (shuffleLinks =<< distributerRoom BulletAmmo 100000)
---        , tToBTree "cor" . return <$> shuffleLinks (cleatOnward corridor)
+        , --        , return $ tToBTree "cor" $ return $ cleatOnward corridor
---        , tToBTree "cor" . return <$> shuffleLinks (cleatOnward corridor)
+          --        --, tToBTree "sdr" . return . cleatOnward <$> slowDoorRoom
---            , passthroughLockKeyLists
+          ----        , tToBTree "sr" . return . cleatOnward <$> tanksRoom [] []
---                    [(sensorRoomRunPast ElectricSensor, takeOne 
+          --        , return $ tToBTree "door" $ return $ cleatOnward door
---                        [-- CRAFT (ENERGYBALLCRAFT TeslaBall) , 
+          --        , return $ tToBTree "cor" $ return $ cleatOnward corridor
---                        HELD SPARKGUN])]
+          --        , tToBTree "sdr" . return . cleatOnward <$>
---                    itemRooms
+          --            (shuffleLinks =<< tanksPipesRoom)
---        , tToBTree "cor" . return <$> shuffleLinks (cleatOnward corridor)
+          --        , return $ tToBTree "cor" $ return $ cleatOnward corridor
---        , tToBTree "cor" . return <$> shuffleLinks (cleatOnward corridor)
+          --        , return $ tToBTree "cor" $ return $ cleatOnward corridor
-        , tToBTree "sdr" . return . cleatOnward <$> 
+          --        , return $ tToBTree "cor" $ return $ cleatOnward corridor
-                (shuffleLinks =<< distributerRoom BulletAmmo 100000)
+          return $ tToBTree "door" $ return $ cleatOnward door
---aaa--        , return $ tToBTree "cor" $ return $ cleatOnward corridor
+        , return $ tToBTree "cor" $ return $ cleatOnward corridor
---aaa--        --, tToBTree "sdr" . return . cleatOnward <$> slowDoorRoom
+        , tutHub
---aaa----        , tToBTree "sr" . return . cleatOnward <$> tanksRoom [] []
+        , chasmSpitTerminal
---aaa--        , return $ tToBTree "door" $ return $ cleatOnward door
+        , return $ tToBTree "cor" $ return $ cleatOnward corridor
---aaa--        , return $ tToBTree "cor" $ return $ cleatOnward corridor
+        , tutLight
---aaa--        , tToBTree "sdr" . return . cleatOnward <$> 
+        , tutDrop
---aaa--            (shuffleLinks =<< tanksPipesRoom)
+        , return $ tToBTree "cor" $ return $ cleatOnward corridor
---aaa--        , return $ tToBTree "cor" $ return $ cleatOnward corridor
+        ----        , AnTree $ pickupTut
---aaa--        , return $ tToBTree "cor" $ return $ cleatOnward corridor
+        ----        , AnTree $ weaponTut
---aaa--        , return $ tToBTree "cor" $ return $ cleatOnward corridor
---aaa        , return $ tToBTree "cor" $ return $ cleatOnward corridor
---aaa        , return $ tToBTree "cor" $ return $ cleatOnward corridor
---aaa        , return $ tToBTree "cor" $ return $ cleatOnward corridor
---aaa        , return $ tToBTree "door" $ return $ cleatOnward door
---aaa        , tutHub
---aaa        , chasmSpitTerminal
---aaa        , tutLight
---aaa        , tutDrop
---aaa        , return $ tToBTree "cor" $ return $ cleatOnward corridor
---aaa        ----        , AnTree $ pickupTut
---aaa        ----        , AnTree $ weaponTut
         ]
 
 foldMTRS ::
@@ -100,29 +88,22 @@ foldMTRS xs = do
     ys <- sequence xs
     return $ foldr1 attachOnward' ys
 
-setRoomInt :: Room -> State LayoutVars (Int, Room)
-setRoomInt x = do
-    i <- nextLayoutInt
-    return (i, x & rmPmnts .:~ sps0 (PutWorldUpdate (f i)))
-  where
-    f i rid _ gw = gw & genInts . at i ?~ (gw ^?! genRooms . ix rid . rmMID . _Just)
-
 setTreeInts :: Tree Room -> State LayoutVars ([Int], Tree Room)
 setTreeInts x = do
-    y <- traverse setRoomInt x
+    y <- traverse storeRoomID x
     return (foldMap ((: []) . fst) y, fmap snd y)
 
 tutDrop :: State LayoutVars (MetaTree Room String)
 tutDrop = do
     x <- shuffleLinks =<< roomNgon 6 100
     i <- nextLayoutInt
-    --let y = decontamRoom i
+    -- let y = decontamRoom i
-    (j, y) <- setRoomInt (decontamRoom i)
+    (j, y) <- storeRoomID (decontamRoom i)
     rm <- roomRectAutoLights 40 100
     return $
         tToBTree "TutDrop" $
             treePost
-                [x & rmInPmnt .:~ (0, t j), y, cleatOnward rm]
+                [x & rmInPmnt .:~ (0, return . t j), y, cleatOnward rm]
   where
     t j gw =
         let x = gw ^? genInts . ix j
@@ -133,8 +114,7 @@ tutDrop = do
                     isUnusedLnk
                     (\(p, a) -> ((p + 10 *.* unitVectorAtAngle (a - pi / 2), a), S.singleton UsedPosLow))
     ss =
-        [ makeTermLine "--------------------------------------------"
+        [ makeTermLine "YOU CAN ONLY CARRY A LIMITED AMOUNT OF ITEMS"
-        , makeTermLine "YOU CAN ONLY CARRY A LIMITED AMOUNT OF ITEMS"
         , makeTermLine "--------------------------------------------"
         ]
             <> tlSetStatus (TerminalPressTo "CONTINUE")
@@ -152,18 +132,24 @@ cChasm = do
     x <- state $ randomR (150, 300)
     y <- state $ randomR (150, 300)
     roomRectAutoLights x y
-        <&> rmLinks %~ setOutLinks (isCornerLink NorthWest)
+        <&> rmLinks
-        <&> rmLinks %~ setInLinks (isCornerLink SouthWest)
+        %~ setOutLinks (isCornerLink NorthWest)
-        <&> rmPmnts <>~ [sps0 $ putConvexChasm (rectNSWE (y -50) 50 0 (x -50))]
+        <&> rmLinks
+        %~ setInLinks (isCornerLink SouthWest)
+        <&> rmPmnts
+        <>~ [sps0 $ putConvexChasm (rectNSWE (y - 50) 50 0 (x - 50))]
 
 lChasm :: State LayoutVars Room
 lChasm = do
     x <- state $ randomR (150, 300)
     y <- state $ randomR (150, 300)
     roomRectAutoLights x y
-        <&> rmLinks %~ setOutLinks (isCornerLink NorthWest)
+        <&> rmLinks
-        <&> rmLinks %~ setInLinks (isCornerLink SouthEast)
+        %~ setOutLinks (isCornerLink NorthWest)
-        <&> rmPmnts <>~ [sps0 $ putConvexChasm (rectNSWE (y -50) 0 0 (x -50))]
+        <&> rmLinks
+        %~ setInLinks (isCornerLink SouthEast)
+        <&> rmPmnts
+        <>~ [sps0 $ putConvexChasm (rectNSWE (y - 50) 0 0 (x - 50))]
 
 -- the Float is the width of the bridge
 zChasm :: Float -> State LayoutVars Room
@@ -171,11 +157,14 @@ zChasm z = do
     x <- state $ randomR (150, 300)
     y <- state $ randomR (150, 300)
     roomRectAutoLights x y
-        <&> rmLinks %~ setOutLinks (isCornerLink NorthWest)
+        <&> rmLinks
-        <&> rmLinks %~ setInLinks (isCornerLink SouthEast)
+        %~ setOutLinks (isCornerLink NorthWest)
-        <&> rmPath %~ addNodesCrossing (V2 0 (y/2),V2 x (y/2))
+        <&> rmLinks
+        %~ setInLinks (isCornerLink SouthEast)
+        <&> rmPath
+        %~ addNodesCrossing (V2 0 (y / 2), V2 x (y / 2))
         <&> rmPmnts
-            <>~ [ sps0 $ putConvexChasm (rectNSWE (y / 2 - z) 0 0 (x -50))
+        <>~ [ sps0 $ putConvexChasm (rectNSWE (y / 2 - z) 0 0 (x - 50))
             , sps0 $ putConvexChasm (rectNSWE y (y / 2 + z) 50 x)
             ]
 
@@ -187,9 +176,12 @@ midChasm = do
     cs <- join $ takeOne [cenoct x y, censquare x y]
     shuffleLinks $
         r
-            & rmLinks %~ setOutLinks (isMidEdgeLink r North)
+            & rmLinks
-            & rmLinks %~ setInLinks (isMidEdgeLink r South)
+            %~ setOutLinks (isMidEdgeLink r North)
-            & rmPmnts <>~ cs
+            & rmLinks
+            %~ setInLinks (isMidEdgeLink r South)
+            & rmPmnts
+            <>~ cs
   where
     censquare x y = do
         z <- state $ randomR (40, 60)
@@ -206,26 +198,31 @@ midChasmPlatform = do
     cs <- join $ takeOne [censquare x y]
     shuffleLinks $
         r
-            & rmLinks %~ setOutLinks (isMidEdgeLink r North)
+            & rmLinks
-            & rmLinks %~ setInLinks (isMidEdgeLink r South)
+            %~ setOutLinks (isMidEdgeLink r North)
-            & rmPmnts <>~ cs
+            & rmLinks
+            %~ setInLinks (isMidEdgeLink r South)
+            & rmPmnts
+            <>~ cs
   where
     censquare x y = do
         z <- state $ randomR (40, 60)
-        let (chsms,clfs) = sqPlatformChasm 20 (min x y/2 - z)
+        let (chsms, clfs) = sqPlatformChasm 20 (min x y / 2 - z)
-        --return [sps0 $ putConvexChasm (rectNSWE (y - z) z z (x - z))]
+        -- return [sps0 $ putConvexChasm (rectNSWE (y - z) z z (x - z))]
-        return [sps0 $ PutChasm
+        return
-            (fmap (fmap (+ V2 (x/2) (y/2))) chsms)
+            [ sps0 $
-            (fmap (fmap (+ V2 (x/2) (y/2))) clfs)
+                PutChasm
-            ]-- (rectNSWE (y - z) z z (x - z))]
+                    (fmap (fmap (+ V2 (x / 2) (y / 2))) chsms)
---    cenoct x y =
+                    (fmap (fmap (+ V2 (x / 2) (y / 2))) clfs)
---        return
+            ] -- (rectNSWE (y - z) z z (x - z))]
---            [sps0 $ putConvexChasm $ (V2 (x / 2) (y / 2) +) <$> polyOrthDist 8 (min x y / 2 - 25)]
+            --    cenoct x y =
+            --        return
+            --            [sps0 $ putConvexChasm $ (V2 (x / 2) (y / 2) +) <$> polyOrthDist 8 (min x y / 2 - 25)]
 
-sqPlatformChasm :: Float -> Float -> ([[Point2]],[[Point2]])
+sqPlatformChasm :: Float -> Float -> ([[Point2]], [[Point2]])
 sqPlatformChasm b a =
-    ( [[ibr,obr,otr,itr],[itr,otr,otl,itl],[itl,otl,obl,ibl],[ibl,obl,obr,ibr]]
+    ( [[ibr, obr, otr, itr], [itr, otr, otl, itl], [itl, otl, obl, ibl], [ibl, obl, obr, ibr]]
-    , [[obr,otr,otl,obl], [ibr,ibl, itl, itr]]
+    , [[obr, otr, otl, obl], [ibr, ibl, itl, itr]]
     )
   where
     obr = V2 a (-a)
@@ -237,10 +234,10 @@ sqPlatformChasm b a =
     itl = V2 (-b) b
     itr = V2 b b
 
-sqSpitChasm :: Float -> Float -> ([[Point2]],[[Point2]])
+sqSpitChasm :: Float -> Float -> ([[Point2]], [[Point2]])
 sqSpitChasm b a =
-    ( [[ibr,obr,otr,itr],[itr,otr,otl,itl],[itl,otl,obl,ibl]]
+    ( [[ibr, obr, otr, itr], [itr, otr, otl, itl], [itl, otl, obl, ibl]]
-    , [[ibr,obr,otr,otl,obl,ibl,itl,itr]]
+    , [[ibr, obr, otr, otl, obl, ibl, itl, itr]]
     )
   where
     obr = V2 a (-a)
@@ -258,55 +255,75 @@ midChasmSpit = do
         y = 300
     r <- roomRectAutoLights x y
     cs <- join $ takeOne [censquare x y]
-    shuffleLinks $
+    foutlnks <-
-        r
+        takeOne
-            & rmLinks %~ setOutLinks 
+            [ \rl ->
-                (\rl -> isMidEdgeLink r North rl 
+                isMidEdgeLink r North rl
                     || isMidEdgeLink r East rl
                     || isMidEdgeLink r West rl
-                )
+            , \rl -> OnEdge North `S.member` (rl ^. rlType)
+                && not (FromEdge East 0 `S.member` (rl ^. rlType))
+                && not (FromEdge West 0 `S.member` (rl ^. rlType))
+            ]
+    shuffleLinks $
+        r
+            & rmLinks %~ setOutLinks foutlnks
             & rmLinks %~ setInLinks (isMidEdgeLink r South)
             & rmPmnts .~ cs
   where
     censquare x y = do
         z <- state $ randomR (40, 60)
-        let (chsms,clfs) = sqSpitChasm 20 (min x y/2 - z)
+        let (chsms, clfs) = sqSpitChasm 20 (min x y / 2 - z)
-        return [sps0 $ PutChasm
+        return
-            (fmap (fmap (+ V2 (x/2) (y/2))) chsms)
+            [ sps0 $
-            (fmap (fmap (+ V2 (x/2) (y/2))) clfs)
+                PutChasm
-            ]-- (rectNSWE (y - z) z z (x - z))]
+                    (fmap (fmap (+ V2 (x / 2) (y / 2))) chsms)
---    cenoct x y =
+                    (fmap (fmap (+ V2 (x / 2) (y / 2))) clfs)
---        return
+            ] -- (rectNSWE (y - z) z z (x - z))]
---            [sps0 $ putConvexChasm $ (V2 (x / 2) (y / 2) +) <$> polyOrthDist 8 (min x y / 2 - 25)]
+            --    cenoct x y =
+            --        return
+            --            [sps0 $ putConvexChasm $ (V2 (x / 2) (y / 2) +) <$> polyOrthDist 8 (min x y / 2 - 25)]
 
 chasmSpitTerminal :: State LayoutVars MTRS
 chasmSpitTerminal = do
     i1 <- nextLayoutInt
     y <- midChasmSpit
-    l3 <- mntLightLnkCond $ resetPLUse $ rprBool $ \rp _ -> isOutLnkNum 0 rp
+    shp <- takeOne [vShape, lShape, jShape, liShape]
-    l4 <- mntLightLnkCond $ resetPLUse $ rprBool $ \rp _ -> isOutLnkNum 1 rp
+    let l3 = mntLightLnkShape shp $ resetPLUse $ rprBool $ \rp _ -> isOutLnkNum 0 rp
-    let y' = y & rmPmnts <>~ [l3,l4]
+        l4 = mntLightLnkShape shp $ resetPLUse $ rprBool $ \rp _ -> isOutLnkNum 1 rp
-    return $ tToBTree "chasmTerm" $ Node (addDoorToggleTerminal' i1 (PS 150 0) y')
+        l5 = mntLightLnkShape shp $ resetPLUse $ rprBool $ \rp _ -> isOutLnkNum 2 rp
-        [treePost [triggerDoorRoom i1, critDeadEnd]
+    -- let y' = y & rmPmnts <>~ [l3, l4, l5]
-        ,treePost [triggerDoorRoom i1, critDeadEnd]
+    let y' = y & rmPmnts <>~ [l3, l4]
-        ,return $ cleatOnward $ triggerDoorRoom i1
+    return $
+        tToBTree "chasmTerm" $
+            Node
+                (addDoorToggleTerminal' i1 (PS 150 0) y')
+                [ treePost [triggerDoorRoom i1, critDeadEnd]
+                , treePost [triggerDoorRoom i1, critDeadEnd]
+                , return $ cleatOnward $ triggerDoorRoom i1
                 ]
 
 polyChasm :: Int -> Float -> State LayoutVars Room
 polyChasm n x =
     shuffleLinks
         =<< ( roomNgon n x
-                <&> rmPmnts <>~ [sps0 $ putConvexChasm $ polyOrthDist n (x -30)]
+                <&> rmPmnts
-                <&> rmLinks %~ setOutLinks (\rl -> rl ^. rlPos . _y > 0)
+                <>~ [sps0 $ putConvexChasm $ polyOrthDist n (x - 30)]
-                <&> rmLinks %~ setInLinks (\rl -> rl ^. rlPos . _y < (5 - x))
+                <&> rmLinks
+                %~ setOutLinks (\rl -> rl ^. rlPos . _y > 0)
+                <&> rmLinks
+                %~ setInLinks (\rl -> rl ^. rlPos . _y < (5 - x))
             )
 
 polyChasmC :: Int -> Float -> State LayoutVars Room
 polyChasmC n x =
     roomNgon n x
-        <&> rmPmnts <>~ [sps0 $ putConvexChasm $ rectNSWE x (60 - x) (-40) 40]
+        <&> rmPmnts
-        <&> rmLinks %~ setInLinks (\rl -> PolyEdge 1 `S.member` (rl ^. rlType))
+        <>~ [sps0 $ putConvexChasm $ rectNSWE x (60 - x) (-40) 40]
-        <&> rmLinks %~ setOutLinks (\rl -> PolyEdge (n -1) `S.member` (rl ^. rlType))
+        <&> rmLinks
+        %~ setInLinks (\rl -> PolyEdge 1 `S.member` (rl ^. rlType))
+        <&> rmLinks
+        %~ setOutLinks (\rl -> PolyEdge (n - 1) `S.member` (rl ^. rlType))
 
 chasmSimpleMaze :: State LayoutVars Room
 chasmSimpleMaze =
@@ -338,9 +355,10 @@ tutLight = do
     return $
         tToBTree "TutLight" $
             treePost
-                [ x & rmPmnts <>~ 
+                [ x
-                    [sps g (PutFlIt led)
+                    & rmPmnts
-                    ,sps g (PutFlIt battery)
+                    <>~ [ sps g (PutFlIt led)
+                        , sps g (PutFlIt battery)
                         ]
                 , corridor & rmPmnts .~ mempty
                 , removeLights y
@@ -353,18 +371,14 @@ tutLight = do
     g = PSPos (\x _ -> f x) (const id) Nothing
       where
         f x = case _rpType x of
-            NotLink{} | null (x ^. rpPlacementUse . at UsedPosFloor)  
+            NotLink{}
-                -> Just (PS (_rpPos x) (_rpDir x)
+                | null (x ^. rpPlacementUse . at UsedPosFloor) ->
-                    , x & rpPlacementUse . at UsedPosFloor ?~ ())
+                    Just
+                        ( PS (_rpPos x) (_rpDir x)
+                        , x & rpPlacementUse . at UsedPosFloor ?~ ()
+                        )
             _ -> Nothing
 
-removeLights :: Room -> Room
-removeLights = rmPmnts %~ mapMaybe f
-  where
-    f x = case x ^. plType of
-        PutLabel "light" -> Nothing
-        _ -> Just x
-
 tutHub :: State LayoutVars (MetaTree Room String)
 tutHub = do
     (is, wbp) <- setTreeInts =<< critsRoom 1
@@ -380,15 +394,15 @@ tutHub = do
     x <-
         shuffleLinks
             . analyserByDoor (RequireEquipment (AMMOMAG DRUMMAG)) i
-            . (rmInPmnt .:~ (0, a))
+            . (rmInPmnt .:~ (0, return . a))
             . addDoorAtNthLinkToggleTerminal 1 ss j
---            . addDoorAtNthLinkToggleInterrupt 2 ds j
+            --            . addDoorAtNthLinkToggleInterrupt 2 ds j
             . addDoorAtNthLinkToggleInterrupt 2 ds j1
             =<< roomNgon 6 100
---    bcor <- treeAttachDeep (return door) <$> blockedCorridor
+    --    bcor <- treeAttachDeep (return door) <$> blockedCorridor
     r1 <- r burstRifle <&> rmPmnts .:~ itemshiftterminal
     r2 <- ammoroom (drumMag & itConsumables ?~ 90) -- <&> rmPmnts .:~ tutorialterminal
-    --r2 <- r (tinMag & itConsumables ?~ 500)
+    -- r2 <- r (tinMag & itConsumables ?~ 500)
     return $
         tToBTree "DoorTest" $
             Node
@@ -396,16 +410,14 @@ tutHub = do
                 [ treeFromPost [triggerDoorRoom i] r1
                 , treeFromPost [triggerDoorRoom j] r2
                 , treeFromTrunk [triggerDoorRoom j1] wbp
---                , (rmClusterStatus . csLinks . at OnwardCluster .~ Nothing)
+                , --                , (rmClusterStatus . csLinks . at OnwardCluster .~ Nothing)
---                    <$> treeAttachDeep wbp (return corridor)
+                  --                    <$> treeAttachDeep wbp (return corridor)
-                , treeFromPost [] (cleatOnward $ triggerDoorRoom k & rmInPmnt . ix 0 . _1 .~ 1)
+                  treeFromPost [] (cleatOnward $ triggerDoorRoom k & rmInPmnt . ix 0 . _1 .~ 1)
                 ]
   where
     ds = ["DESTROY THIS TO OPEN THE DOOR"]
     ss =
-        [ makeTermLine "---------------------------------------------"
+        [ makeTermLine "SOME TERMINALS HAVE A PROMPT"
-        , makeTermLine "YOU CAN INTERACT WITH SOME TERMINALS DIRECTLY"
-        , makeTermLine "           THESE WILL DISPLAY A PROMPT SYMBOL"
         , makeTermLine "   *****"
         , makeTermLine "  *     *    TYPE OR SCROLL TO ENTER COMMANDS"
         , makeTermLine "  *  >  *"
@@ -455,8 +467,8 @@ getCrsFromRooms' is gw = fmap h $ show $ foldMap f (IM.restrictKeys (gw ^. genRo
     js = getRoomsFromInts is gw
     f rm = shortShow <$> rm ^.. rmPmnts . each . plType
 
---f rm = foldMap g $ rm ^. rmPmnts
+-- f rm = foldMap g $ rm ^. rmPmnts
---g x = case x ^. plType of
+-- g x = case x ^. plType of
 --    PutCrit _ -> [x ^?! plMID . _Just]
 --    _ -> []
 
@@ -480,7 +492,7 @@ sensorTut =
 
 --        <> tlSetStatus (TerminalPressTo "CONTINUE")
 
-tutRezBox :: RandomGen g => State g Room
+tutRezBox :: (RandomGen g) => State g Room
 tutRezBox = do
     ls <- rezColor
     return $
@@ -495,11 +507,13 @@ tutRezBox = do
                                 <> tlDoEffect TmWdWdPowerDownTerminal
                                 --                            <> tlDoEffect (TmWdWdLeaveTerminal "QUIT")
                             )
-                                & plSpot .~ PS (V2 20 0) 0
+                            & plSpot
+                            .~ PS (V2 20 0) 0
                ]
             & restrictInLinks (\(V2 _ h, _) -> h < 1)
             & restrictOutLinks (\(V2 _ h, _) -> h > 59)
-            & rmName .~ "tutRezBox"
+            & rmName
+            .~ "tutRezBox"
   where
     s w = tutorialMessage1 (w ^. gwWorld . cWorld . cwGen . cwgSeed)
 
@@ -517,15 +531,16 @@ tutorialMessage1 i =
            , makeTermLine "          [D]       TO MOVE"
            , makeTermLine "--------------------------------------------"
            ]
+
 --        <> tlSetStatus (TerminalPressTo "CONTINUE")
 --        <> [ makeTermLine "AFTER EXITING THIS TERMINAL YOUR INVENTORY"
 --           , makeTermLine "        AND NEARBY OBJECTS WILL BE DISPLAYED"
 --           , makeTermLine "--------------------------------------------"
 --           ]
 passthroughLockKeyLists ::
-        [(Int -> State LayoutVars (MetaTree Room String), State LayoutVars ItemType)]
+    [(Int -> State LayoutVars (MetaTree Room String), State LayoutVars ItemType)] ->
-        -> [(ItemType, State LayoutVars (MetaTree Room String))]
+    [(ItemType, State LayoutVars (MetaTree Room String))] ->
-        -> State LayoutVars (MetaTree Room String)
+    State LayoutVars (MetaTree Room String)
 passthroughLockKeyLists ls ks = do
     i <- nextLayoutInt
     (functionlockroom, randomitemidentity) <- takeOne ls

src/Dodge/TestString.hs

@@ -30,9 +30,12 @@ import qualified Data.Map.Strict as M
 import NewInt
 import Data.Foldable
 import Data.Monoid
+import RandomHelp
 
 testStringInit :: Universe -> [String]
-testStringInit u = fmap show $ u ^.. uvWorld . cWorld . lWorld . machines . each . mcHP
+testStringInit u = [evalState (takeOne ["a","b"]) (_randGen $ _uvWorld u)]
+--    (fmap show $ u ^.. uvWorld . cWorld . lWorld . machines . each . mcType . _McDamSensor . sensAmount)
+--    <> (fmap show $ u ^.. uvWorld . cWorld . lWorld . machines . each . mcMaterial)
 --testStringInit u = map show (u ^.. uvWorld . cWorld . lWorld . machines . traverse . mcDir)
 --testStringInit u =  map show
 --    (u ^.. uvWorld . cWorld . lWorld . machines . traverse .mcType . _McDistributer)
@@ -61,20 +64,6 @@ showManObj (SelCloseItem x) = "CloseItem " ++ show x
 showManObj SortCloseButton = "SortCloseButton"
 showManObj (SelCloseButton x) = "CloseButton " ++ show x
 
-
---testStringInit u = fromMaybe mempty $ do
---    inv <- fmap invLDT $ u ^? uvWorld . cWorld . lWorld . creatures . ix 0 . crInv
---    invitm <- inv ^? ix 1
---    return $ concatMap (prettyLDT (\(x,_,_,_) -> take 5 (show $ x ^. itType . iyBase))) [invitm]
-
---testStringInit u = maybe [] invTree (u ^? uvWorld . cWorld . lWorld . creatures . ix 0 . crInv)
---    [fromMaybe "" $ do
---    cr <- u ^? uvWorld . cWorld . lWorld . creatures . ix 0
---    i <- cr ^? crManipulation . manObject . inInventory . ispItem
---    fmap (show . canAttachTargeting) (cr ^? crInv . ix i) 
---    ]
-
-
 showTimeFlow :: TimeFlowStatus -> String
 showTimeFlow tfs = case tfs of
     RespawnDelay i -> "Respawndelay"++show i

src/Dodge/Tree/Compose.hs

@@ -3,7 +3,6 @@
 -- | Combining and composing trees of trees.
 module Dodge.Tree.Compose (
     tToBTree,
-    overwriteLabel,
     composeTree,
     decomposeTree,
     numMetaTree,
@@ -16,6 +15,7 @@ module Dodge.Tree.Compose (
     attachOnward,
     attachOnward',
     showIntsString,
+    overwriteLabel,
     module Dodge.Data.MetaTree
 ) where
 

src/Dodge/Update.hs

@@ -6,7 +6,6 @@ module Dodge.Update (updateUniverse) where
 import Data.Function (on)
 import Dodge.Zoning.Wall
 import Bound
-import Dodge.Data.DoubleTree
 import Dodge.HeldUse
 import Dodge.DoubleTree
 import Dodge.Item.Grammar
@@ -337,7 +336,7 @@ muzzleWallCheck w cr = fromMaybe cr $ do
         else let v = minimumBy (compare `on` norm) vs
             in cr & crPos . _xy +~ normalize v
   where
-    f loc = map (muzzlePos loc cr)  (itemMuzzles $ loc ^. locDT . dtValue . _1)
+    f loc = map (muzzlePos loc cr)  (itemMuzzles $ loc)
     g cp wls p = case collidePoint cp p wls of
         (ep,Just _) -> Just (ep - p)
         _ -> Nothing

src/Dodge/Update/Camera.hs

@@ -183,8 +183,7 @@ heldAimZoom = \case
     FLAMETORRENT -> 1
     FLAMEWALL -> 1
     BLOWTORCH -> 1
-    SPARKGUN -> 1
+    TESLACOIL ->  1.5
-    TESLAGUN ->  1.5
     TRACTORGUN ->  1.5
     RLAUNCHER ->  1.5
     RLAUNCHERX{} ->  1.5

src/Dodge/Wall/Damage.hs

@@ -43,6 +43,7 @@ damageWall wlid dt w = fromMaybe (mempty,w) $ do
                 & maybeDestroyDoor drid
         _ -> (mempty, w')
 
+-- the way that sensor damage is registered is not yet ideal
 damageMachine :: Damage -> Int -> Int -> World -> (S.Set Int2, World)
 damageMachine dam x mcid w = case w ^? cWorld . lWorld . machines . ix mcid of
     Just mc | Just se <- mc ^? mcType . _McDamSensor

src/Dodge/WorldEffect.hs

@@ -59,7 +59,6 @@ doWdWd = \case
     UseInvItem invid pt -> \w -> fromMaybe w (useItem invid pt w)
     WdWdBurstFireRepetition cid invid -> \w -> fromMaybe w $ do
         cr <- w ^? cWorld . lWorld . creatures . ix cid
-        --itree <- allInvLocs (cr ^. crInv) ^? ix invid . _2 . locLDT
         loc <- invIndents (fmap (\k -> w ^?! cWorld . lWorld . items . ix k) $ cr ^. crInv) ^? ix (_unNInt invid) . _2
         return $ heldEffectMuzzles loc cr w
 

src/RandomHelp.hs

@@ -2,13 +2,13 @@
 {- Helpers for random generation.  -}
 module RandomHelp (
     module System.Random,
---    module Control.Monad.State,
+    --    module Control.Monad.State,
     module RandomHelp,
     module Control.Monad.Trans.State.Lazy,
 ) where
 
 import Control.Monad
---import Control.Monad.State
+-- import Control.Monad.State
 import Control.Monad.Trans.State.Lazy
 import Data.List
 import Geometry
@@ -21,8 +21,25 @@ randomRanges = join . takeOne . f
     f (x : y : ys) = state (randomR (x, y)) : f ys
     f _ = []
 
-takeOne :: RandomGen g => [a] -> State g a
+takeOne :: (RandomGen g) => [a] -> State g a
-takeOne xs = state (randomR (0, length xs - 1)) >>= (\i -> return (xs !! i))
+takeOne xs = state (randomR (0, length xs - 1)) >>= \i -> return (xs !! i)
+
+takeOneRem :: (RandomGen g) => [a] -> State g (Maybe (a, [a]))
+takeOneRem [] = return Nothing
+takeOneRem xs =
+    state (randomR (0, length xs - 1)) >>= \i -> do
+        let (ys, (z : zs)) = splitAt i xs
+        return $ Just (z, ys <> zs)
+
+takeOneFiltered :: (RandomGen g) => (a -> Bool) -> [a] -> State g (Maybe a)
+takeOneFiltered t xs = do
+    m <- takeOneRem xs
+    f m
+  where
+    f Nothing = return Nothing
+    f (Just (y, ys))
+        | t y = return $ Just y
+        | otherwise = takeOneFiltered t ys
 
 takeOneWeighted :: (RandomGen g, Random b, Ord b, Num b) => [b] -> [a] -> State g a
 takeOneWeighted ws xs = state (randomR (0, sum ws)) >>= (\w -> return (xs !! i w ws))
@@ -32,25 +49,25 @@ takeOneWeighted ws xs = state (randomR (0, sum ws)) >>= (\w -> return (xs !! i w
         | otherwise = 1 + i (y - z) zs
     i _ _ = 0
 
---{-# OPTIONS -Wno-incomplete-uni-patterns #-}
+-- {-# OPTIONS -Wno-incomplete-uni-patterns #-}
-takeOneMore :: RandomGen g => ([a], [a]) -> State g ([a], [a])
+takeOneMore :: (RandomGen g) => ([a], [a]) -> State g ([a], [a])
 takeOneMore (_, []) = error "trying to takeOneMore from empty list"
 takeOneMore (xs, ys) = do
     i <- state $ randomR (0, length ys - 1)
     let (zs, w : ws) = splitAt i ys
     return (w : xs, zs ++ ws)
 
-takeNMore :: RandomGen g => Int -> ([a], [a]) -> State g ([a], [a])
+takeNMore :: (RandomGen g) => Int -> ([a], [a]) -> State g ([a], [a])
 takeNMore n p = foldl' (flip $ const (>>= takeOneMore)) (return p) [1 .. n]
 
-takeN :: RandomGen g => Int -> [a] -> State g [a]
+takeN :: (RandomGen g) => Int -> [a] -> State g [a]
 takeN 0 _ = return []
 takeN i xs = fst <$> takeNMore i ([], xs)
 
 -- | Randomly shuffle a list.
-shuffle :: RandomGen g => [a] -> State g [a]
+shuffle :: (RandomGen g) => [a] -> State g [a]
 shuffle xs = do
-    rands <- forM [0 .. length xs -1] $ \i -> state $ randomR (0, i)
+    rands <- forM [0 .. length xs - 1] $ \i -> state $ randomR (0, i)
     let f ys rand =
             let (as, b : bs) = splitAt rand ys
              in (as ++ bs, b)
@@ -58,94 +75,95 @@ shuffle xs = do
     return $ forceElements zs `seq` zs
 
 -- | Randomly shuffle the tail of a list, not safe.
-shuffleTail :: RandomGen g => [a] -> State g [a]
+shuffleTail :: (RandomGen g) => [a] -> State g [a]
 shuffleTail (x : xs) = (x :) <$> shuffle xs
 shuffleTail _ = undefined
 
 -- select elements from a list randomly
 -- each element has the same independent chance of being selected
-randomSelectionFromList :: RandomGen g => Float -> [a] -> State g [a]
+randomSelectionFromList :: (RandomGen g) => Float -> [a] -> State g [a]
 randomSelectionFromList = filterM . const . randProb
 
-randProb :: RandomGen g => Float -> State g Bool
+randProb :: (RandomGen g) => Float -> State g Bool
 randProb p = do
     p1 <- state $ randomR (0, 1)
     return (p1 < p)
 
-randInCirc :: RandomGen g => Float -> State g Point2
+randInCirc :: (RandomGen g) => Float -> State g Point2
 randInCirc = flip randInArc (2 * pi)
 
-randOnCirc :: RandomGen g => Float -> State g Point2
+randOnCirc :: (RandomGen g) => Float -> State g Point2
 randOnCirc r = do
-    a <- state $ randomR (0, 2*pi)
+    a <- state $ randomR (0, 2 * pi)
     return $ r *.* unitVectorAtAngle a
 
-randInArc :: RandomGen g => Float -> Float -> State g Point2
+randInArc :: (RandomGen g) => Float -> Float -> State g Point2
 randInArc = randInArcStrip 0
 
-randInArcStrip :: RandomGen g => Float -> Float -> Float -> State g Point2
+randInArcStrip :: (RandomGen g) => Float -> Float -> Float -> State g Point2
 randInArcStrip minrad maxRad maxangle = do
     rad <- state $ randomR (minrad, maxRad)
     ang <- state $ randomR (0, maxangle)
     return $ rad *.* unitVectorAtAngle ang
 
-randOnUnitSphere :: RandomGen g => State g Point3
+randOnUnitSphere :: (RandomGen g) => State g Point3
 randOnUnitSphere = do
     z <- state $ randomR (negate 1, 1)
     longitude <- state $ randomR (0, 2 * pi)
     let (V2 x y) = sqrt (1 - z ^ (2 :: Int)) *.* unitVectorAtAngle longitude
     return (V3 x y z)
 
-randOnHemisphere :: RandomGen g => State g Point3
+randOnHemisphere :: (RandomGen g) => State g Point3
 randOnHemisphere = do
     z <- state $ randomR (0, 1)
     longitude <- state $ randomR (0, 2 * pi)
     let (V2 x y) = sqrt (1 - z ^ (2 :: Int)) *.* unitVectorAtAngle longitude
     return (V3 x y z)
 
-randInHemisphere :: RandomGen g => State g Point3
+randInHemisphere :: (RandomGen g) => State g Point3
 randInHemisphere = do
     p <- randOnHemisphere
     r <- state $ randomR (0, 1)
     return $ r *.*.* p
 
-randInRect :: RandomGen g => Float -> Float -> State g Point2
+randInRect :: (RandomGen g) => Float -> Float -> State g Point2
 randInRect w h = do
     x <- state $ randomR (0, w)
     y <- state $ randomR (0, h)
     return (V2 x y)
 
-maybeTakeOne :: RandomGen g => [a] -> State g (Maybe a)
+maybeTakeOne :: (RandomGen g) => [a] -> State g (Maybe a)
 maybeTakeOne [] = return Nothing
 maybeTakeOne xs = state (randomR (0, length xs - 1)) >>= (\i -> return (Just (xs !! i)))
 
-randsSpread :: RandomGen g => (Float, Float) -> Int -> State g [Float]
+randsSpread :: (RandomGen g) => (Float, Float) -> Int -> State g [Float]
 randsSpread (a, b) i
     | i <= 0 = error "tried to take <= 0 randsSpread"
     | otherwise = zipWith (+) [a + x, a + 2 * x ..] <$> replicateM i (state $ randomR (0, x))
   where
     x = (b - a) / fromIntegral i
 
-randsOnCirc :: RandomGen g => Int -> State g [Float]
+randsOnCirc :: (RandomGen g) => Int -> State g [Float]
 randsOnCirc = randsSpread (0, 2 * pi)
 
-randPeakedParam :: RandomGen g => Int -> Float -> Float -> Float -> State g Float
+randPeakedParam :: (RandomGen g) => Int -> Float -> Float -> Float -> State g Float
 randPeakedParam i a b c = do
     x <- state $ randomR (-1, 1)
     let y = x ^ i
-    return $ if y < 0
+    return $
-        then a + y * (a-b)
+        if y < 0
-        else b + y * (c-b)
+            then a + y * (a - b)
+            else b + y * (c - b)
 
-randPeaked :: RandomGen g => Float -> Float -> Float -> State g Float
+randPeaked :: (RandomGen g) => Float -> Float -> Float -> State g Float
 randPeaked = randPeakedParam 3
 
-randFromPair :: RandomGen g => Float -> (a,a) -> State g a
+randFromPair :: (RandomGen g) => Float -> (a, a) -> State g a
-randFromPair x (l,r) = do
+randFromPair x (l, r) = do
-    y <- state $ randomR (0,1)
+    y <- state $ randomR (0, 1)
     if x < y then return l else return r
 
-shufflePair :: RandomGen g => (a,a) -> State g (a,a)
+shufflePair :: (RandomGen g) => (a, a) -> State g (a, a)
-shufflePair (x,y) = do
+shufflePair (x, y) = do
-    v <- state $ randomR (0::Float,1)
+    v <- state $ randomR (0 :: Float, 1)
-    if v > 0.5 then return (x,y) else return (y,x)
+    if v > 0.5 then return (x, y) else return (y, x)