Cleanup

src/Dodge/Base/Collide.hs

@@ -21,7 +21,6 @@ module Dodge.Base.Collide (
     bouncePoint,
     circOnSomeWall,
     circOnAnyCr,
-    overlapCircWalls,
     overlapCircWallsClosest,
     crsNearPoint,
     allVisibleWalls,
@@ -35,6 +34,8 @@ module Dodge.Base.Collide (
     collide3,
 ) where
 
+import Data.Foldable
+import qualified Data.IntMap.Strict as IM
 import Control.Lens
 import Control.Monad
 import qualified Data.IntSet as IS
@@ -49,7 +50,7 @@ import FoldableHelp
 import Geometry
 import Linear
 
-collidePoint :: Point2 -> Point2 -> [Wall] -> (Point2, Maybe Wall)
+collidePoint :: Foldable t => Point2 -> Point2 -> t Wall -> (Point2, Maybe Wall)
 {-# INLINE collidePoint #-}
 collidePoint sp ep = foldl' f (ep, Nothing)
   where
@@ -73,15 +74,15 @@ doBounce x sp ep (p, mwl) = fmap f mwl
         , reflVelWallDamp x wl (ep -.- sp)
         )
 
---bounceBall ::
+-- bounceBall ::
 --    Float ->
 --    Point2 ->
 --    Point2 ->
 --    Float ->
 --    [Wall] ->
 --    Maybe (Point2, Point2)
---{-# INLINE bounceBall #-}
+-- {-# INLINE bounceBall #-}
---bounceBall x sp ep r = doBounce x sp ep . collideCircWalls sp ep r
+-- bounceBall x sp ep r = doBounce x sp ep . collideCircWalls sp ep r
 
 bouncePoint ::
     (Wall -> Bool) ->
@@ -106,7 +107,8 @@ collide3Chasms sp w m =
     foldl'
         (flip (collide3Chasm sp))
         m
-        (foldMap loopPairs $ w ^. cWorld . chasms)
+        -- (foldMap loopPairs $ w ^. cWorld . chasms)
+        (w ^. cWorld . cliffs)
 
 collide3Chasm :: Point3 -> (Point2, Point2) -> (Point3, MPO) -> (Point3, MPO)
 collide3Chasm sp ab (ep, m) =
@@ -185,39 +187,40 @@ wallToSurface wl = (g x, g $ vNormal (x - y), [(g x, g (y - x)), (g y, g (x - y)
 
 -- this COULD be written in terms of collidePointWallsFilterStream, TODO test
 -- whether this is actually faster
-collidePointTestFilter :: (Wall -> Bool) -> Point2 -> Point2 -> [Wall] -> Bool
+collidePointTestFilter :: (Wall -> Bool) -> Point2 -> Point2 -> IM.IntMap Wall -> Bool
 {-# INLINE collidePointTestFilter #-}
 collidePointTestFilter t sp ep =
     any (isJust . uncurry (intersectSegSeg sp ep) . _wlLine)
-        . filter t
+        . IM.filter t
 
 ---- this COULD be written in terms of collidePointWallsFilterStream, TODO test
 ---- whether this is actually faster
---collidePointTestFilter :: (Wall -> Bool) -> Point2 -> Point2 -> StreamOf Wall -> Bool
+-- collidePointTestFilter :: (Wall -> Bool) -> Point2 -> Point2 -> StreamOf Wall -> Bool
---{-# INLINE collidePointTestFilter #-}
+-- {-# INLINE collidePointTestFilter #-}
---collidePointTestFilter t sp ep = runIdentity
+-- collidePointTestFilter t sp ep = runIdentity
 --    . S.any_ (isJust . uncurry (intersectSegSeg sp ep) . _wlLine)
 --    . S.filter t
 
 collidePointWallsFilter :: (Wall -> Bool) -> Point2 -> Point2 -> World -> (Point2, Maybe Wall)
 {-# INLINE collidePointWallsFilter #-}
-collidePointWallsFilter t sp ep = collidePoint sp ep . filter t . wlsNearSeg sp ep
+collidePointWallsFilter t sp ep = collidePoint sp ep . IM.filter t . wlsNearSeg sp ep
 
---overlapSegWalls :: Point2 -> Point2 -> StreamOf Wall
+-- overlapSegWalls :: Point2 -> Point2 -> StreamOf Wall
 --    -> StreamOf (Point2,Wall)
---{-# INLINE overlapSegWalls #-}
+-- {-# INLINE overlapSegWalls #-}
---overlapSegWalls sp ep = S.mapMaybe $ \wl -> uncurry (intersectSegSeg sp ep) (_wlLine wl) <&> (,wl)
+-- overlapSegWalls sp ep = S.mapMaybe $ \wl -> uncurry (intersectSegSeg sp ep) (_wlLine wl) <&> (,wl)
 
-overlapSegWalls :: Point2 -> Point2 -> [Wall] -> [(Point2, Wall)]
+overlapSegWalls :: Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap (Point2, Wall)
 {-# INLINE overlapSegWalls #-}
-overlapSegWalls sp ep = mapMaybe 
+overlapSegWalls sp ep = IM.mapMaybe $
-    $ \wl -> uncurry (intersectSegSeg sp ep) (_wlLine wl) <&> (,wl)
+    \wl -> uncurry (intersectSegSeg sp ep) (_wlLine wl) <&> (,wl)
 
 visibleWalls :: Point2 -> Point2 -> World -> [(Point2, Wall)]
 {-# INLINE visibleWalls #-}
 visibleWalls sp ep =
     takeUntil (wlIsOpaque . snd)
         . sortOn (dist sp . fst)
+        . IM.elems
         . overlapSegWalls sp ep
         . wlsNearSeg sp ep
 
@@ -227,16 +230,12 @@ allVisibleWalls w = concatMap (flip (visibleWalls vPos) w . (+.+ vPos)) $ nRays
   where
     vPos = w ^. wCam . camViewFrom
 
-overlapCircWalls ::
+overlapCircWalls :: Point2 -> Float -> [Wall] -> [(Point2, Wall)]
-    Point2 ->
-    Float ->
-    [Wall] ->
-    [(Point2, Wall)]
 {-# INLINE overlapCircWalls #-}
-overlapCircWalls p r = mapMaybe dointersect
+overlapCircWalls p r = mapMaybe g
   where
-    dointersect wl = f (_wlLine wl) <&> (,wl)
+    g wl = f (_wlLine wl) <&> (,wl)
-    f (a, b) = intersectSegSeg p (p +.+ r *.* normalizeV ((0.5 *.* (a +.+ b)) -.- p)) a b
+    f (a, b) = intersectSegSeg p (p + r *^ vNormal (normalizeV (b - a))) a b
 
 circHitWall :: Point2 -> Point2 -> Float -> World -> Bool
 circHitWall sp ep r w =
@@ -255,7 +254,8 @@ collideCircWalls :: Point2 -> Point2 -> Float -> [Wall] -> (Point2, Maybe Wall)
 collideCircWalls sp ep rad = foldl' findPoint (ep, Nothing)
   where
     findPoint (p, mwl) wl =
-        maybe (p, mwl) (,Just wl) . uncurry (intersectSegSeg sp p)
+        maybe (p, mwl) (,Just wl)
+            . uncurry (intersectSegSeg sp p)
             . shiftbyrad
             . _wlLine
             $ wl
@@ -271,14 +271,7 @@ collideCircWalls sp ep rad = foldl' findPoint (ep, Nothing)
 
 overlapCircWallsClosest :: Point2 -> Float -> [Wall] -> Maybe (Point2, Wall)
 {-# INLINE overlapCircWallsClosest #-}
-overlapCircWallsClosest p r =
+overlapCircWallsClosest p r = safeMinimumOn (dist p . fst) . overlapCircWalls p r
-    safeMinimumOn (dist p . fst)
-        . overlapCircWalls p r
-
---overlapCircWallsClosest :: Point2 -> Float -> StreamOf Wall -> Maybe (Point2,Wall)
---{-# INLINE overlapCircWallsClosest #-}
---overlapCircWallsClosest p r = minStreamOn (dist p . fst)
---    . overlapCircWalls p r
 
 {- | Test if a circle collides with any wall.
  - Note no check on whether the wall is walkable.
@@ -312,7 +305,7 @@ hasButtonLOS :: Point2 -> Point2 -> World -> Bool
 {-# INLINE hasButtonLOS #-}
 hasButtonLOS _ _ = const True
 
---hasButtonLOS p1 p2 =
+-- hasButtonLOS p1 p2 =
 --    not
 --        . collidePointTestFilter (not . _wlTouchThrough) p1 p2
 --        . wlsNearSeg p1 p2
@@ -322,9 +315,9 @@ hasLOSIndirect :: Point2 -> Point2 -> World -> Bool
 hasLOSIndirect p1 p2 =
     not
         . collidePointTestFilter wlIsOpaque p1 p2
+--        . IM.elems
         . wlsNearSeg p1 p2
 
-
 canSee :: Int -> Int -> World -> Bool
 {-# INLINE canSee #-}
 canSee i j w = hasLOS p1 p2 w

src/Dodge/Base/Coordinate.hs

@@ -2,13 +2,15 @@ module Dodge.Base.Coordinate (
     worldPosToScreen,
     screenToWorldPos,
     mouseWorldPos,
+    mouseWorldPosW,
     worldPosToResOffset,
 ) where
 
+import Dodge.Data.World
 import Control.Lens
-import Dodge.Data.Camera
+--import Dodge.Data.Camera
 import Dodge.Data.Config
-import Dodge.Data.Input
+--import Dodge.Data.Input
 import Dodge.WindowSize
 import Geometry
 import Linear
@@ -37,6 +39,9 @@ worldPosToResOffset cfig cam p =
 mouseWorldPos :: Input -> Camera -> Point2
 mouseWorldPos inp cam = screenToWorldPos cam (inp ^. mousePos)
 
+mouseWorldPosW :: World -> Point2
+mouseWorldPosW w = mouseWorldPos (w ^. input) (w ^. wCam)
+
 screenToWorldPos :: Camera -> Point2 -> Point2
 screenToWorldPos cam p =
     (cam ^. camCenter) + (1 / (cam ^. camZoom)) *.* rotateV (cam ^. camRot) p

src/Dodge/Button/Draw.hs

@@ -1,16 +1,18 @@
-module Dodge.Button.Draw where
+module Dodge.Button.Draw (drawButton) where
 
+import Data.Maybe
+import Dodge.Data.LWorld
 import Color
-import Dodge.Data.Button
 import Geometry
 import Shape
 import ShapePicture
 import Control.Lens
 
-drawButton :: Button -> SPic
+drawButton :: LWorld -> Button -> SPic
-drawButton bt = case bt ^. btEvent of
+drawButton lw bt = case bt ^. btEvent of
     ButtonPress {_bpColor = col} -> defaultDrawButton col bt
     ButtonSwitch {_bsColor1 = col1, _bsColor2 = col2} -> drawSwitch col1 col2 bt
+    ButtonDumbSwitch i -> drawDumbSwitch (fromMaybe True $ lw ^? triggers . ix i)
     ButtonAccessTerminal _ -> mempty
 
 drawSwitch :: Color -> Color -> Button -> SPic
@@ -26,6 +28,19 @@ drawSwitch col1 col2 bt
             ]
         )
 
+drawDumbSwitch :: Bool -> SPic
+drawDumbSwitch t
+    |  t = flick $ pi / 4
+    | otherwise = flick (negate (pi / 4))
+  where
+    flick a = noPic
+        ( mconcat
+            [ colorSH red . upperBox Small Typical 20 $ rectNSWE (-2) (-5) (-10) 10
+            , colorSH (dim red) . translateSH (V3 0 (-2) 20) . rotateSH a . upperBox Small Typical 2 $
+                    rectNSWE 10 0 (-2) 2
+            ]
+        )
+
 defaultDrawButton :: Color -> Button -> SPic
 defaultDrawButton col bt = noPic
     ( translateSHz 15 . colorSH col $ upperBox Small Typical 5 buttonGeometry

src/Dodge/Button/Event.hs

@@ -12,6 +12,7 @@ doButtonEvent = \case
     ButtonPress False f _ -> buttonFlip f
     ButtonSwitch _ f _ _ True -> buttonFlip f
     ButtonSwitch f _ _ _ False -> buttonFlip f
+    ButtonDumbSwitch i -> \_ -> cWorld . lWorld . triggers . ix i %~ not
     ButtonAccessTerminal tid -> const $ accessTerminal tid
 
 buttonFlip :: WdWd -> Button -> World -> World

src/Dodge/Creature.hs

@@ -209,10 +209,12 @@ inventoryX c = case c of
         [ makeTypeCraftNum 2 MICROCHIP
         ]
     "J" ->
-        [ laser
+        [ capacitor
+        , makeTypeCraft TRANSFORMER
+        , laser
         , battery
-        --, dualBeam
+        ] 
-        ] <> makeTypeCraftNum 10 TRANSFORMER
+        <> makeTypeCraftNum 5 BEAMSPLITTER
     "K" ->
         [ autoRifle
         , tinMag

src/Dodge/Creature/Action/Blink.hs

@@ -5,6 +5,7 @@ module Dodge.Creature.Action.Blink (
     unsafeBlinkAction,
 ) where
 
+import qualified Data.IntMap.Strict as IM
 import Linear
 import Dodge.Creature.Radius
 import Dodge.Zoning.Wall
@@ -34,7 +35,7 @@ blinkActionMousePos cr w =
     p1 = w ^. cWorld . lWorld . lAimPos
     cpos = cr ^. crPos . _xy
     --p2 = bouncePoint (const True) 1 cpos p1 w
-    p2 = pushIntoMaybe $ collideCircWalls cpos p1 r (wlsNearSeg cpos p1 w)
+    p2 = pushIntoMaybe $ collideCircWalls cpos p1 r (IM.elems $ wlsNearSeg cpos p1 w)
     r = crRad $ cr ^. crType
     p3 = maybe p1 ((+.+ squashNormalizeV (cpos -.- p1)) . fst) p2 
     --p3 = maybe p1 (const 0) p2 

src/Dodge/Creature/Impulse/UseItem.hs

@@ -50,7 +50,7 @@ useItemLoc cr loc pt w
     | otherwise = (\loc' -> useItemLoc cr loc' pt w) =<< locUp' loc
   where
     aimuse 
-        | LaserWeaponSF <- sf = True
+        | LaserWeaponXSF {} <- sf = True
         | HeldPlatformSF <- sf = True
         | PulseBallSF <- sf = True
         | PlasmaSF <- sf = True

src/Dodge/Creature/State.hs

@@ -35,7 +35,6 @@ import Dodge.Zoning.Creature
 import FoldableHelp
 import Geometry
 import LensHelp
-import Picture
 import qualified Quaternion as Q
 import RandomHelp
 import qualified SDL
@@ -218,7 +217,7 @@ shineTargetLaser cr loc w = fromMaybe (w & pointittarg . itTgPos .~ Nothing) $ d
                     { _lpPhaseV = 1
                     , _lpDir = _crDir cr + argV (Q.qToV2 q)
                     , _lpPos = pos
-                    , _lpColor = col
+--                    , _lpColor = col
                     , _lpType = TargetingLaser (_itID itm)
                     }
   where
@@ -228,12 +227,11 @@ shineTargetLaser cr loc w = fromMaybe (w & pointittarg . itTgPos .~ Nothing) $ d
     x = 1
     isammolink AmmoMagSF{} = True
     isammolink _ = False
-    pos = cr ^. crPos . _xy + xyV3 (rotate3 cdir p)
+    pos = cr ^. crPos . _xy + xyV3 (rotate3z cdir p)
     cdir = _crDir cr
     itm = itmtree ^. dtValue . _1
     pointittarg = cWorld . lWorld . items . ix itid . itTargeting
     itid = itm ^. itID . unNInt
-    col = blue -- mixColors reloadFrac (1-reloadFrac) blue red
 
 shineTorch :: Creature -> LocationDT OItem -> World -> World
 shineTorch cr loc = fromMaybe id $ do
@@ -252,7 +250,7 @@ shineTorch cr loc = fromMaybe id $ do
     x = 10
     isammolink AmmoMagSF{} = True
     isammolink _ = False
-    pos = _crPos cr + rotate3 cdir (p + Q.rotate q (V3 5 0 1.5))
+    pos = _crPos cr + rotate3z cdir (p + Q.rotate q (V3 5 0 1.5))
     cdir = _crDir cr
 
 -- this probably needs to be set to null when dropped as well?

src/Dodge/Creature/Test.hs

@@ -22,6 +22,7 @@ module Dodge.Creature.Test (
     crHasTarget,
     crStratConMatches,
     crSafeDistFromTarg,
+    hasAutoDoorBody,
 ) where
 
 import Linear
@@ -136,3 +137,11 @@ isAnimate :: Creature -> Bool
 isAnimate cr = case _crActionPlan cr of
     Inanimate -> False
     _ -> True
+
+hasAutoDoorBody :: Creature -> Bool
+hasAutoDoorBody cr = case cr ^. crHP of
+    HP {} -> True
+    CrIsCorpse {} -> True
+    CrIsGibs -> False
+    CrIsPitted -> False
+    

src/Dodge/Creature/Update.hs

@@ -150,7 +150,7 @@ chasmTestLiving cr w
   where
     tocr = cWorld . lWorld . creatures . ix (_crID cr)
     g = uncurry $ circOnSeg (cr ^. crPos . _xy) (crRad $ cr ^. crType)
-    f = circInPolygon (cr ^. crPos . _xy) (crRad $ cr ^. crType)
+    f = pointInPoly (cr ^. crPos . _xy)
 
 chasmTestCorpse :: Creature -> World -> World
 chasmTestCorpse cr w
@@ -162,13 +162,12 @@ chasmTestCorpse cr w
         w
             & soundContinue (CrChasm (_crID cr)) (cr ^. crPos . _xy) debrisS (Just 100)
             & tocr . crPos . _xy +~ normalizeV (vNormal (x - y))
-            & chasmRotate cr (x - y)
     | any f (w ^. cWorld . chasms) = w & tocr . crZVel -~ 0.5
     | otherwise = w
   where
     tocr = cWorld . lWorld . creatures . ix (_crID cr)
     g = uncurry $ circOnSeg (cr ^. crPos . _xy) (crRad $ cr ^. crType)
-    f = circInPolygon (cr ^. crPos . _xy) (crRad $ cr ^. crType)
+    f = pointInPoly (cr ^. crPos . _xy)
 
 chasmRotate :: Creature -> Point2 -> World -> World
 chasmRotate cr v w

src/Dodge/CreatureEffect.hs

@@ -34,6 +34,7 @@ doCrBl cb = case cb of
     CrCanShoot -> error "got rid of crCanShoot"
     CrIsAiming -> crIsAiming
     CrIsAnimate -> isAnimate
+    CrOpenAutoDoor -> \cr -> isAnimate cr && hasAutoDoorBody cr
 
 doCrAc :: CrAc -> Creature -> Action
 doCrAc ca = case ca of

src/Dodge/Data/Button.hs

@@ -23,6 +23,7 @@ data ButtonEvent
         , _bsColor2 :: Color
         , _btOn :: Bool
         }
+    | ButtonDumbSwitch { _bdsTrigger :: Int }
     | ButtonAccessTerminal {_btTermID :: Int}
 
 data Button = Button

src/Dodge/Data/ComposedItem.hs

@@ -37,7 +37,8 @@ data ItemSF -- Structural Function
     | GrenadeHitEffectSF
     | ToggleSF
     | MapperSF
-    | LaserWeaponSF
+--    | LaserWeaponSF
+    | LaserWeaponXSF {_lasWepXSF :: Int}
     | PulseLaserSF
     | CapacitorSF
     | TransformerSF
@@ -45,6 +46,7 @@ data ItemSF -- Structural Function
     | PlasmaSF
     | TorchSF
     | PumpSF
+    | BeamSplitterSF
     deriving (Eq, Ord, Show, Read)
 
 type CItem = (Item, ItemSF)

src/Dodge/Data/Creature.hs

@@ -30,6 +30,7 @@ import Dodge.Data.Creature.State
 import Dodge.Data.Item
 import Dodge.Data.Material
 import Geometry.Data
+import qualified Data.IntSet as IS
 --import qualified IntMapHelp as IM
 
 data Creature = Creature
@@ -57,6 +58,7 @@ data Creature = Creature
     , _crIntention :: Intention
     , _crName :: String
     , _crDeathTimer :: Int
+    , _crWallTouch :: IS.IntSet
     }
 
 data CrHP

src/Dodge/Data/CreatureEffect.hs

@@ -18,6 +18,7 @@ data WdCrBl
     deriving (Eq, Ord, Show, Read) --Generic, Flat)
 
 data CrBl = CrCanShoot | CrIsAiming | CrIsAnimate
+    | CrOpenAutoDoor
     deriving (Eq, Ord, Show, Read) --Generic, Flat)
 
 data CrAc = CrTurnAround

src/Dodge/Data/Door.hs

@@ -40,7 +40,10 @@ data Door = Door
     , _drMounts :: [MountedObject]
     }
 
-data DoorUpdate = DoorDoNothing | DoorLerp {_drLerpSpeed :: Float}
+data DoorUpdate 
+    = DoorDoNothing 
+    | DoorLerp {_drLerpSpeed :: Float}
+    | DoorLerpWithTimer {_drLerpTimer :: Int, _drLerpSpeed :: Float}
 
 
 makeLenses ''Door

src/Dodge/Data/Input.hs

@@ -26,7 +26,7 @@ data MouseContext
     | OverCombEscape
     | OverTerminal {_mcoTermID :: Int, _mcoTermStatus :: TerminalStatus}
     | OutsideTerminal
-    | MouseGameRotate
+    | MouseGameRotate {_mcoRotateDist :: Float}  -- TODO warp mouse to this distance
     | OverDebug {_mcoDBBool :: DebugBool, _mcoDBInt :: Int}
     deriving (Show)
 
@@ -46,8 +46,13 @@ data Input = Input
     , _textInput :: [Either TermSignal Char]
     , _scrollTestFloat :: Float
     , _scrollTestInt :: Int
+    , _inputMemory :: InputMemory
     }
 
+data InputMemory
+    = WasMouseGameRotating
+    | WasNotMouseGameRotating
+
 data TermSignal
     = TSescape
     | TSreturn

src/Dodge/Data/Item/Combine.hs

@@ -62,6 +62,7 @@ data CraftType
     | PUMP
     | MOTOR
     | TRANSFORMER
+    | BEAMSPLITTER
     | PRISM
     | LIGHTER
     | MAGNET

src/Dodge/Data/Laser.hs

@@ -5,7 +5,7 @@ module Dodge.Data.Laser where
 
 import NewInt
 import Dodge.Data.Item.Location
-import Color
+--import Color
 import Control.Lens
 import Data.Aeson
 import Data.Aeson.TH
@@ -20,7 +20,6 @@ data Laser = Laser
     { _lpPhaseV :: Float
     , _lpPos :: Point2
     , _lpDir :: Float
-    , _lpColor :: Color
     , _lpType :: LaserType
     }
     deriving (Eq, Ord, Show, Read) --Generic, Flat)

src/Dodge/Data/WorldEffect.hs

@@ -25,15 +25,14 @@ data SoundFilter
 data WdWd
     = NoWorldEffect
     | SetTrigger Bool Int
-    | WorldEffects [WdWd] -- probably best to avoid recursive types if possible...
     | SetLSCol Point3 Int
+    | SetTriggerAndSetLSCol Bool Int Point3 Int
     | AccessTerminal Int
     | UnlockInv
     | SoundStart SoundOrigin Point2 SoundID (Maybe Int)
     | MakeStartCloudAt Point3
     | TorqueCr Float Int
     | WdWdNegateTrig Int
---    | WdWdFromItCrixWdWd (LabelDoubleTree ComposeLinkType Item) Int ItCrWdWd
     | MakeTempLight LSParam Int
     | MakeTempLightFade Float LSParam Int
     | UseInvItem Int Int -- invid presstime

src/Dodge/Debug.hs

@@ -42,6 +42,45 @@ overDebugEvent u = fromMaybe u $ do
 
 debugEvent :: DebugBool -> Universe -> Universe
 debugEvent db u = u & uvDebug . at db .~ debugItem db u
+    & debugEvent' db
+
+-- possibly don't want this running when the game is paused/not running normally
+-- note this happens before functionalUpdate
+debugEvent' :: DebugBool -> Universe -> Universe
+debugEvent' = \case
+    Collision_test -> id
+    Circ_collision_test -> id
+    Show_walls_near_point_cursor -> id
+    Show_walls_near_segment -> id
+    Display_debug -> id
+    Noclip -> id
+    Remove_LOS -> id
+    Cull_more_lights -> id
+    Close_shape_culling -> id
+    Bound_box_screen -> id
+    Show_ms_frame -> id
+    View_gr_boundaries -> id
+    View_rm_boundaries -> id
+    Show_bound_box -> id
+    Show_wall_search_rays -> id
+    Show_dda_test -> id
+    Show_far_wall_detect -> id
+    Show_walls_near_you -> id
+    Show_zone_near_point_cursor -> id
+    Show_zone_circ -> id
+    Inspect_wall -> id
+    Cr_awareness -> id
+    Show_sound -> id
+    Cr_status -> id
+    Mouse_position -> id
+    Walls_info -> id
+    Pathing -> id
+    Show_path_between -> id
+    Show_writable_values -> id
+    Show_mouse_click_pos -> id
+    Debug_get -> id
+    Debug_put -> id
+    Muzzle_positions -> id
 
 debugItem :: DebugBool -> Universe -> Maybe [DebugItem]
 debugItem = \case
@@ -109,7 +148,6 @@ doDebugGet u =
   where
     f s = DebugItem s (setClip s)
 
-
 debugShowPath :: Universe -> DebugItem
 debugShowPath u =
     DebugItem (u ^. uvDebugPathShowType . to show) f
@@ -259,7 +297,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)
+    f cr loc = foldMap (g . muzzlePos loc cr)  (itemMuzzles loc)
       where
         g :: Point3Q -> Picture
         g pq = translate3 (pq ^. _1) $ crossPic 5

src/Dodge/Debug/Picture.hs

@@ -276,7 +276,7 @@ drawFarWallDetect w =
             ( \q ->
                 line
                     [ p
-                    , fst $ collidePoint p q $ filter wlIsOpaque $ wlsNearSeg p q w
+                    , fst $ collidePoint p q $ filter wlIsOpaque $ IM.elems $ wlsNearSeg p q w
                     ]
             )
         $ getViewpoints p (_cWorld w)

src/Dodge/Default/Creature.hs

@@ -55,6 +55,7 @@ defaultCreature =
 --        , _crStatistics = CreatureStatistics 50 50 50
         , _crDeathTimer = 5  -- how long a creature remains standing 
                              -- after a killing blow has been dealt
+        , _crWallTouch = mempty
         }
 
 --defaultCreatureSkin :: CreatureType

src/Dodge/Default/Door.hs

@@ -1,4 +1,4 @@
-module Dodge.Default.Door ( defaultDoor) where
+module Dodge.Default.Door (defaultDoor) where
 
 import Dodge.Data.Door
 
@@ -7,7 +7,7 @@ defaultDoor =
     Door
         { _drID = 0
         , _drTrigger = WdBlConst False
-        , _drUpdate = DoorLerp 1
+        , _drUpdate = DoorLerp 2
         , _drZeroPos = (0, 0)
         , _drOnePos = (0, 0)
         , _drLerp = 0

src/Dodge/Default/World.hs

@@ -27,6 +27,7 @@ defaultInput =
         , _smoothScrollAmount = 0
         , _scrollTestFloat = 1
         , _scrollTestInt = 0
+        , _inputMemory = WasNotMouseGameRotating
         }
 
 defaultWorld :: World

src/Dodge/Door.hs

@@ -20,9 +20,10 @@ import Picture.Data
 import Shape.Data
 
 updateDoor :: Door -> World -> (S.Set Int2, World)
-updateDoor dr w
+updateDoor dr w = case dr ^. drUpdate of
-    | DoorLerp x <- dr ^. drUpdate = doorLerp x dr w
+    DoorLerp x -> doorLerp x dr w
-    | otherwise =
+    DoorLerpWithTimer n x -> doorLerpWithTimer n x dr w
+    DoorDoNothing ->
         ( mempty
         , foldl' (doDoorMount (doDoorLerp dr (dr ^. drLerp))) w (dr ^. drMounts)
         )
@@ -68,3 +69,38 @@ doorLerp speed dr w = fromMaybe (mempty, domounts (dr ^. drLerp) w) $ do
             soundContinue (WallSound drid) (fst $ doDoorLerp dr x) slideDoorS (Just 1)
         | otherwise = id
 
+doorLerpWithTimer :: Int -> Float -> Door -> World -> (S.Set Int2, World)
+doorLerpWithTimer n speed dr w = fromMaybe (mempty, domounts (dr ^. drLerp) w & uptimer) $ do
+    x <- newlerp
+    let ps = wlposs x
+        ps' = wlposs (dr ^. drLerp)
+        is = foldMap (S.fromList . uncurry (zoneOfSeg peZoneSize)) (ps <> ps')
+    -- it seems possible that this will miss some paths: we don't add zones for the
+    -- old footprint. Seems unlikely, but a possible cause of pathfinding bugs
+    return
+        ( is
+        , domounts x $
+            f x
+                & playSound x
+                & cWorld . lWorld . doors . ix drid . drLerp .~ x
+                & uptimer
+        )
+  where
+    domounts x w' = foldl' (doDoorMount (doDoorLerp dr x)) w' (dr ^. drMounts)
+    f = ifoldl' (flip . moveWallID) w . wlposs
+    wlposs x = (dr ^. drFootPrint) & each . each %~ shiftPointBy (doDoorLerp dr x)
+    clerp = dr ^. drLerp
+    newlerp
+        | toOpen && clerp < 1 = Just . min 1 $ clerp + speed
+        | clerp > 0 && not toOpen = Just . max 0 $ clerp - speed
+        | otherwise = Nothing
+    uptimer = cWorld . lWorld . doors . ix drid . drUpdate . drLerpTimer %~ updatetimer
+    updatetimer
+        | doWdBl (_drTrigger dr) w = const 20
+        | otherwise = max 0 . subtract 1
+    toOpen = doWdBl (_drTrigger dr) w || n > 0
+    drid = _drID dr
+    playSound x
+        | _drPushedBy dr == PushesItself =
+            soundContinue (WallSound drid) (fst $ doDoorLerp dr x) slideDoorS (Just 1)
+        | otherwise = id

src/Dodge/Euse.hs

@@ -41,8 +41,8 @@ useMagShield mt _ cr w =
             , _mgField = mt
             }
 
---setWristShieldPos :: Item -> Creature -> EquipSite -> World -> World
+-- setWristShieldPos :: Item -> Creature -> EquipSite -> World -> World
---setWristShieldPos itm cr x = moveWallIDUnsafe i wlline
+-- setWristShieldPos itm cr x = moveWallIDUnsafe i wlline
 --  where
 --    i = _itParamID $ _itParams itm
 --    wlline = (f (V3 (-10) 7 0), f (V3 10 7 0))
@@ -62,17 +62,12 @@ useMagShield mt _ cr w =
 --    _ -> w
 
 createHeadLamp :: Item -> Creature -> World -> World
-createHeadLamp _ cr w =
+createHeadLamp _ cr =
-    w
+    cWorld
-        & cWorld
         . lWorld
         . lights
         .:~ LSParam
-            ( _crPos cr
+            (_crPos cr + rotate3z (_crDir cr) (translateToES cr OnHead (V3 5 0 3)))
-                +.+.+ rotate3
-                    (_crDir cr)
-                    (translateToES cr OnHead (V3 5 0 3))
-            )
             200
             0.7
 
@@ -103,9 +98,9 @@ onEquipWristShield itm cr w =
         . at i
         ?~ forceField{_wlID = i}
         & setWristShieldPos
-            ( itm & itParams .~ ItemParamID{_itParamID = i}
+            (itm & itParams .~ ItemParamID{_itParamID = i})
-            )
+            cr
-            cr esite
+            esite
   where
     i = IM.newKey (w ^. cWorld . lWorld . walls)
     esite = w ^?! cWorld . lWorld . items . ix (itm ^. itID . unNInt) . itLocation . ilEquipSite . _Just
@@ -132,4 +127,4 @@ setWristShieldPos itm cr esite w = w & moveWallIDUnsafe i wlline
     --    g
     --        | twists cr = (+.+.+ V3 (-5) 10 0)
     --        | otherwise = id
-    f = (+.+ cr ^. crPos . _xy) . stripZ . rotate3 (_crDir cr) . handtrans
+    f = (+ cr ^. crPos . _xy) . stripZ . rotate3z (_crDir cr) . handtrans

src/Dodge/Event/Input.hs

@@ -49,9 +49,7 @@ handleMouseMotionEvent mmev cfig = set mousePos themousepos . set mouseMoving Tr
   where
     P (V2 x y) = mouseMotionEventPos mmev
     themousepos =
-        V2
+        V2 (fromIntegral x - 0.5 * windowXFloat cfig) (0.5 * windowYFloat cfig - fromIntegral y)
-            (fromIntegral x - 0.5 * windowXFloat cfig)
-            (0.5 * windowYFloat cfig - fromIntegral y)
 
 handleMouseWheelEvent :: MouseWheelEventData -> Input -> Input
 handleMouseWheelEvent mwev = scrollAmount +~ fromIntegral y

src/Dodge/HeldUse.hs

@@ -10,6 +10,7 @@ module Dodge.HeldUse (
     itemMuzzles,
 ) where
 
+import Dodge.Laser.Update
 import Color
 import Control.Applicative
 import Control.Monad
@@ -37,7 +38,7 @@ import Dodge.Tesla
 import Geometry
 import qualified IntMapHelp as IM
 import LensHelp
-import Linear (_xy, _xyz)
+import Linear (_xy,_xyz)
 import ListHelp
 import NewInt
 import Picture.Base
@@ -167,7 +168,7 @@ locMuzzles loc
             & ix 0 . mzInaccuracy .~ 0
             & ix 0 . mzFlareType .~ TeslaGunFlare
 --    | otherwise = itemMuzzles $ loc ^. locDT . dtValue . _1
-    | otherwise = itemMuzzles $ loc
+    | otherwise = itemMuzzles loc
 
 itemMuzzles :: LocationDT OItem -> [Muzzle]
 itemMuzzles loc = case itm ^. itType of
@@ -175,12 +176,21 @@ itemMuzzles loc = case itm ^. itType of
     DETECTOR{} ->
         dbwMuzzles & ix 0 . mzEffect .~ MuzzleDetector
             & ix 0 . mzAmmoSlot . aps .~ UseExactly 100
-    LASER ->
+    LASER -> case loc ^? locDT . dtValue . _2 . lasWepXSF of
-        dbwMuzzles
+        Nothing ->
-            & ix 0 . mzPos .~ V2 6 0
+            dbwMuzzles
-            & ix 0 . mzInaccuracy .~ 0
+                & ix 0 . mzPos .~ V2 6 0
-            & ix 0 . mzFlareType .~ LasGunFlare
+                & ix 0 . mzInaccuracy .~ 0
-            & ix 0 . mzEffect .~ MuzzleLaser
+                & ix 0 . mzFlareType .~ LasGunFlare
+                & ix 0 . mzEffect .~ MuzzleLaser
+        Just i -> join
+            [dbwMuzzles
+                & ix 0 . mzPos .~ V2 6 x
+                & ix 0 . mzInaccuracy .~ 0
+                & ix 0 . mzFlareType .~ NoLightFlare
+                & ix 0 . mzEffect .~ MuzzleLaser
+            | x <- spreadAroundCenter i 3
+            ] & ix (i `div` 2) . mzFlareType .~ LasGunFlare
     _ -> []
   where
     itm = loc ^. locDT . dtValue . _1
@@ -677,9 +687,9 @@ makeMuzzleFlare (p, q) loc = \case
             . muzFlareAt (V4 10 10 1 3) p dir
     HeavySmokeFlare -> basicMuzFlare (p ^. _xy) dir
     LasGunFlare ->
-        flareCircleAt (getLaserColor loc) 0.8 p
+        flareCircleAt (ltToCol $ getLaserDamage loc) 0.8 p
             . ( cWorld . lWorld . lights
-                    .:~ LSParam p 100 (getLaserColor loc ^. _xyz) -- p had z=10
+                    .:~ LSParam p 100 (ltToCol (getLaserDamage loc) ^. _xyz) -- p had z=10
               )
     TeslaGunFlare -> cWorld . lWorld . lights .:~ LSParam p 100 (V3 0 0 1) -- p had z=10
   where
@@ -718,9 +728,6 @@ getLaserPhaseV = const 1
 getLaserDamage :: LocationDT OItem -> LaserType
 getLaserDamage = const (DamageLaser 11)
 
-getLaserColor :: LocationDT OItem -> Color
-getLaserColor = const yellow
-
 basicMuzFlare :: Point2 -> Float -> World -> World
 basicMuzFlare pos dir =
     (cWorld . lWorld . lights .:~ LSParam (pos `v2z` 20) 100 (V3 1 1 0.5))
@@ -857,7 +864,6 @@ creatureShootLaser (p, q) loc =
         (getLaserPhaseV loc)
         (p ^. _xy)
         (Q.qToAng q)
-        (getLaserColor loc)
 
 shootLaser ::
     SoundOrigin ->
@@ -865,17 +871,15 @@ shootLaser ::
     Float ->
     Point2 ->
     Float ->
-    Color ->
     World ->
     World
-shootLaser so lt pv p dir col =
+shootLaser so lt pv p dir =
     ( cWorld . lWorld . lasers
         .:~ Laser
             { _lpType = lt
             , _lpPhaseV = pv
             , _lpPos = p
             , _lpDir = dir
-            , _lpColor = col
             }
     )
         . soundContinue so p tone440sawtoothquietS (Just 2)
@@ -933,8 +937,7 @@ removeAmmoFromMag x magid
 getBulletType :: DTree OItem -> Maybe Bullet
 getBulletType magtree =
     (magtree ^? dtValue . _1 . to magAmmoParams . _Just . ampBullet)
-        <&> buPayload .~ bpayload
+        <&> (buPayload .~ bpayload) . (buEffect .~ beffect)
-        <&> buEffect .~ beffect
   where
     bpayload = fromMaybe (BulPlain 100) $ do
         attree <- find ispayload (magtree ^. dtLeft)
@@ -1177,7 +1180,7 @@ doGenFloat (UniRandFloat x y) g = randomR (x, y) g
 
 mcShootLaser :: Item -> Machine -> World -> World
 mcShootLaser _ mc =
-    shootLaser (MachinePrimarySound (_mcID mc)) (DamageLaser 11) 1 pos dir yellow
+    shootLaser (MachinePrimarySound (_mcID mc)) (DamageLaser 11) 1 pos dir
   where
     pos = _mcPos mc +.+ 20 *.* unitVectorAtAngle dir
     dir = (mc ^?! mcType . mctTurret . tuDir)

src/Dodge/Inventory.hs

@@ -1,4 +1,4 @@
---{-# LANGUAGE TupleSections #-}
+-- {-# LANGUAGE TupleSections #-}
 module Dodge.Inventory (
     rmInvItem,
     destroyInvItem,
@@ -14,15 +14,22 @@ module Dodge.Inventory (
     swapItemWith,
     destroyItem,
     destroyAllInvItems,
+    multiSelScroll,
+    changeSwapSelSet,
+    concurrentIS,
+    collectInvItems,
+    shiftInvItemsUp,
+    shiftInvItemsDown,
 ) where
 
-import Dodge.Euse
+import Control.Monad
-import Linear
 import Data.Function
+import qualified Data.IntSet as IS
 import Data.Maybe
 import Dodge.Base
 import Dodge.Data.SelectionList
 import Dodge.Data.World
+import Dodge.Euse
 import Dodge.Inventory.Location
 import Dodge.Inventory.RBList
 import Dodge.Inventory.Swap
@@ -30,6 +37,7 @@ import Dodge.SelectionSections
 import Geometry
 import qualified IntMapHelp as IM
 import LensHelp
+import Linear
 import ListHelp
 import NewInt
 
@@ -65,7 +73,8 @@ destroyItem itid w = case w ^? cWorld . lWorld . items . ix itid . itLocation of
     Just InInv{_ilCrID = cid, _ilInvID = invid} -> destroyInvItem cid invid w
     Just OnTurret{} -> error "need to write code for destroying items on turrets"
     Just OnFloor ->
-        w & cWorld . lWorld . items . at itid .~ Nothing
+        w
+            & cWorld . lWorld . items . at itid .~ Nothing
             & cWorld . lWorld . floorItems . at itid .~ Nothing
     Just InVoid -> w & cWorld . lWorld . items . at itid .~ Nothing
 
@@ -74,7 +83,7 @@ destroyItem itid w = case w ^? cWorld . lWorld . items . ix itid . itLocation of
 rmInvItem :: Int -> NewInt InvInt -> World -> World
 rmInvItem cid invid w =
     w
-        & dounequipfunction --the ordering of these is
+        & dounequipfunction -- the ordering of these is
         & pointcid . crInv %~ f -- important
         & removeAnySlotEquipment
         & cWorld . lWorld . items . ix itid . itLocation . ilEquipSite .~ Nothing
@@ -97,12 +106,13 @@ rmInvItem cid invid w =
     itm = w ^?! cWorld . lWorld . items . ix itid
     dounequipfunction = effectOnRemove itm cr
     removeAnySlotEquipment = fromMaybe id $ do
-        epos <- itm ^?
+        epos <-
-                     itLocation
+            itm
-                    . ilEquipSite
+                ^? itLocation
-                    . _Just
+                . ilEquipSite
+                . _Just
         return $ pointcid . crEquipment . at epos .~ Nothing
---        return $ pointcid . crEquipment .~ mempty
+    --        return $ pointcid . crEquipment .~ mempty
     maxk = fmap fst $ IM.lookupMax $ _unNIntMap $ cr ^. crInv
     f inv =
         let (xs, ys) = IM.split (_unNInt invid) $ _unNIntMap inv
@@ -114,23 +124,90 @@ rmInvItem cid invid w =
 
 updateCloseObjects :: World -> World
 updateCloseObjects w =
-    w & hud . closeItems %~ h citems
+    w
+        & hud . closeItems %~ h citems
         & hud . closeButtons %~ h cbts
   where
     h a b = intersect b a `union` a
     lw = w ^. cWorld . lWorld
-    citems = map NInt $ IM.keys $ IM.intersection (lw ^. items) 
+    citems =
-        $ IM.filter (isclose . _flItPos) (lw^.floorItems)
+        map NInt $
-    cbts = lw^..buttons . each . filtered canpress . filtered (isclose . _btPos) . to _btID
+            IM.keys $
+                IM.intersection (lw ^. items) $
+                    IM.filter (isclose . _flItPos) (lw ^. floorItems)
+    cbts = lw ^.. buttons . each . filtered canpress . filtered (isclose . _btPos) . to _btID
     canpress bt = case bt ^. btEvent of
         ButtonPress{_btOn = t} -> not t
         ButtonAccessTerminal tid -> fromMaybe False $ do
             x <- lw ^? terminals . ix tid . tmStatus
             return (x /= TerminalDeactivated)
         _ -> True
-    isclose x = dist y x < 40 && hasButtonLOS y x w
+    isclose x = dist y x < 30 && hasButtonLOS y x w
     y = you w ^. crPos . _xy
 
+changeSwapSelSet :: Int -> World -> World
+changeSwapSelSet yi w
+    | yi >= 0 = foldl' (&) w $ replicate yi (swapSelSet shiftSetUp)
+    | otherwise = foldl' (&) w $ replicate (negate yi) (swapSelSet shiftSetDown)
+
+swapSelSet :: (Int -> IS.IntSet -> World -> World) -> World -> World
+swapSelSet f w = fromMaybe w $ do
+    Sel j i is' <- w ^. hud . diSelection
+    let is = if IS.null is' 
+        then IS.singleton i
+        else is'
+    return $
+        if concurrentIS is
+            then f j is w
+            else collectInvItems j is w
+
+shiftSetUp :: Int -> IS.IntSet -> World -> World
+shiftSetUp j is w = fromMaybe w $ do
+    (mini, _) <- IS.minView is
+    guard (mini > 0)
+    return $ shiftInvItemsUp j is w
+
+shiftSetDown :: Int -> IS.IntSet -> World -> World
+shiftSetDown j is w = fromMaybe w $ do
+    (maxi, _) <- IS.maxView is
+    (maxinv, _) <- IM.lookupMax =<< (w ^? hud . diSections . ix j . ssItems)
+    guard (maxi < maxinv)
+    return $ shiftInvItemsDown j is w
+
+shiftInvItemsDown :: Int -> IS.IntSet -> World -> World
+shiftInvItemsDown j is w = fromMaybe w $ do
+    let i = IS.findMax is
+    guard . isJust $ w ^? hud . diSections . ix j . ssItems . ix i
+    return $ IS.foldr f w is
+  where
+    f i' = swapItemWith g (j, i')
+    g i' m = fst <$> IM.lookupGT i' m
+
+
+shiftInvItemsUp :: Int -> IS.IntSet -> World -> World
+shiftInvItemsUp j is w = IS.foldl' f w is
+  where
+    f w' i' = swapItemWith g (j, i') w'
+    g i' m = fst <$> IM.lookupLT i' m
+
+concurrentIS :: IS.IntSet -> Bool
+concurrentIS = go . IS.minView
+  where
+    go x = fromMaybe True $ do
+        (i, is) <- x
+        (j, js) <- IS.minView is
+        return $ i + 1 == j && go (Just (j, js))
+
+collectInvItems :: Int -> IS.IntSet -> World -> World
+collectInvItems secid is w = fromMaybe w $ do
+    guard $ secid == 0
+    (j, js) <- IS.minView is
+    return $ h j js w
+  where
+    h j js w' = fromMaybe w' $ do
+        (k, ks) <- IS.minView js
+        return . h (j + 1) ks $ swapInvItems (\_ _ -> Just (j + 1)) k w'
+
 changeSwapSel :: Int -> World -> World
 changeSwapSel yi w
     | yi >= 0 = foldl' (&) w $ replicate yi (changeSwapWith $ f IM.cycleLT)
@@ -138,6 +215,27 @@ changeSwapSel yi w
   where
     f g i m = fst <$> g i m
 
+multiSelScroll :: Int -> World -> World
+multiSelScroll yi w
+    | yi >= 0 = foldl' (&) w $ replicate yi (multiSelScroll' $ f IM.lookupLT)
+    | otherwise = foldl' (&) w $ replicate (negate yi) (multiSelScroll' $ f IM.lookupGT)
+  where
+    f g i m = fst <$> g i m
+
+multiSelScroll' :: (Int -> IM.IntMap (SelectionItem ()) -> Maybe Int) -> World -> World
+multiSelScroll' f w = fromMaybe w $ do
+    Sel j i is <- w ^. hud . diSelection
+    ss <- w ^? hud . diSections . ix j . ssItems
+    k <- f i ss
+    let insertordelete 
+            | not (i `IS.member` is) && k `IS.member` is = IS.delete k
+            | k `IS.member` is = IS.delete i 
+            | otherwise = IS.insert i . IS.insert k
+    return $
+        w
+            & hud . diSelection . _Just . slSet %~ insertordelete
+            & hud . diSelection . _Just . slInt .~ k
+
 changeSwapOther ::
     ((Int -> Identity Int) -> ManipulatedObject -> Identity ManipulatedObject) ->
     Int ->
@@ -155,7 +253,13 @@ changeSwapOther manlens n f i w = fromMaybe w $ do
     return $
         w
             & swapAnyExtraSelection i k
-            & cWorld . lWorld . creatures . ix 0 . crManipulation . manObject . manlens
+            & cWorld
+                . lWorld
+                . creatures
+                . ix 0
+                . crManipulation
+                . manObject
+                . manlens
                 %~ doswap
             & hud . closeItems %~ swapIndices i k
             & hud . diSelection . _Just . slInt %~ doswap
@@ -173,8 +277,8 @@ swapItemWith f (j, i) = case j of
     _ -> id
 
 changeSwapWith :: (Int -> IM.IntMap (SelectionItem ()) -> Maybe Int) -> World -> World
-changeSwapWith f w 
+changeSwapWith f w
-    | Just (Sel j i _) <- w ^. hud . diSelection = swapItemWith f (j,i) w
+    | Just (Sel j i _) <- w ^. hud . diSelection = swapItemWith f (j, i) w
     | otherwise = w
 
 invSetSelection :: Selection -> World -> World
@@ -192,7 +296,8 @@ scrollAugInvSel :: Int -> World -> World
 scrollAugInvSel yi w
     | yi == 0 = w
     | otherwise =
-        w & hud %~ doscroll
+        w
+            & hud %~ doscroll
             & worldEventFlags . at InventoryChange ?~ ()
             & setInvPosFromSS
             & cWorld . lWorld %~ crUpdateItemLocations 0
@@ -203,7 +308,8 @@ scrollAugInvSel yi w
 
 scrollAugNextInSection :: World -> World
 scrollAugNextInSection w =
-    w & hud %~ doscroll
+    w
+        & hud %~ doscroll
         & worldEventFlags . at InventoryChange ?~ ()
         & setInvPosFromSS
         & cWorld . lWorld %~ crUpdateItemLocations 0

src/Dodge/Inventory/SelectionList.hs

@@ -236,7 +236,9 @@ closeButtonToSelectionItem w i = do
 btText :: Button -> String
 btText bt = case _btEvent bt of
     ButtonPress {} -> "BUTTON"
-    ButtonSwitch {_btOn = t} -> if t then "SWITCH\\" else "SWITCH/"
+    --ButtonSwitch {_btOn = t} -> if t then "SWITCH\\" else "SWITCH/"
+    ButtonSwitch {} -> "SWITCH"
+    ButtonDumbSwitch {} -> "SWITCH"  -- do we want to show switch status?
     ButtonAccessTerminal i -> "TERMINAL " ++ show i
 
 closeItemToTextPictures :: Item -> ([String], Color)

src/Dodge/Item/AimStance.hs

@@ -13,7 +13,10 @@ itemAimStance dt
     | otherwise = itemBaseStance $ dt ^. dtValue . _1
   where
     islasweapon = dt ^. dtValue . _1 . itType == CRAFT TRANSFORMER
-        && dt ^? dtRight . ix 0 . dtValue . _2 == Just LaserWeaponSF
+        && islas (dt ^? dtRight . ix 0 . dtValue . _2) -- == Just LaserWeaponSF
+    islas = \case
+        Just (LaserWeaponXSF {}) -> True
+        _ -> False
 
 itemBaseStance :: Item -> AimStance
 itemBaseStance itm = case itm ^. itType of

src/Dodge/Item/Draw/SPic.hs

@@ -42,6 +42,7 @@ craftItemSPic = \case
     PIPE -> colorSH green $ xCylinderST 3 10
     TUBE -> colorSH cyan $ xCylinderST 5 20
     HARDWARE -> colorSH orange $ upperPrismPolyST 3 $ square 4
+    BEAMSPLITTER -> colorSH orange $ upperPrismPolyST 3 $ square 4
     SPRING -> colorSH green $ xCylinderST 1 5
     HOSE -> colorSH green $ xCylinderST 1 10
     TAPE ->

src/Dodge/Item/Grammar.hs

@@ -53,8 +53,9 @@ itemAboveAttachables (itm,sf) = case (itm ^. itType, sf) of
 itemBelowAttachables :: CItem -> [ItemSF]
 itemBelowAttachables (itm,sf) = case (itm ^. itType, sf) of
     (LASER, WeaponTargetingSF) -> getAmmoLinks itm
-    (LASER, LaserWeaponSF) -> [PulseBallSF] <> getAmmoLinks itm
+    (LASER, LaserWeaponXSF 1) -> [PulseBallSF,BeamSplitterSF] <> getAmmoLinks itm
-    (LASER, PulseBallSF) -> [PulseBallSF]
+    (LASER, LaserWeaponXSF {}) -> replicate 5 BeamSplitterSF <> getAmmoLinks itm
+--    (LASER, PulseBallSF) -> [PulseBallSF]
     --(HELD LASER, _) -> [PulseBallSF]
     (HELD LED, _) -> getAmmoLinks itm
     (ATTACH CAPACITOR, _) -> [AmmoMagSF 0 ElectricalAmmo]
@@ -151,10 +152,12 @@ treeToPotentialFunction ldt = case ldt ^. dtValue . _1 . itType of
     ATTACH GYROSCOPE -> S.singleton ProjectileStabiliserSF
     HELD GLAUNCHER -> S.singleton UnderBarrelPlatformSF
     HELD BURSTRIFLE -> S.singleton UnderBarrelPlatformSF
-    LASER | sf == WeaponTargetingSF -> S.fromList [WeaponTargetingSF,LaserWeaponSF]
+    LASER | sf == WeaponTargetingSF -> S.fromList (WeaponTargetingSF: [LaserWeaponXSF i| i <- [1..6]])
+    LASER -> S.fromList [LaserWeaponXSF i| i <- [1..6]]
     -- following limits items to ten ammo slots
     _ | AmmoMagSF _ x <- ldt ^. dtValue . _2 -> S.fromList [AmmoMagSF i x | i <- [0..9]]
     ATTACH CAPACITOR -> S.fromList [CapacitorSF,PulseBallSF]
+    CRAFT BEAMSPLITTER -> S.singleton BeamSplitterSF
     _ -> S.singleton (ldt ^. dtValue . _2)
   where
     sf = ldt ^. dtValue . _2
@@ -172,7 +175,7 @@ leftIsParentCombine ltree rtree = do
         & dtValue %~ f
 
 updateLeftParentSF :: ItemType -> ItemSF -> ItemSF -> ItemSF
-updateLeftParentSF LASER WeaponTargetingSF TransformerSF = LaserWeaponSF
+updateLeftParentSF LASER WeaponTargetingSF TransformerSF = LaserWeaponXSF 1
 updateLeftParentSF _ psf _ = psf
 
 rightIsParentCombine :: DTComb CItem
@@ -183,7 +186,8 @@ rightIsParentCombine ltree rtree = do
         & dtValue %~ f
 
 updateRightParentSF :: ItemType -> ItemSF -> ItemSF -> ItemSF
-updateRightParentSF LASER LaserWeaponSF CapacitorSF = PulseLaserSF
+updateRightParentSF LASER (LaserWeaponXSF 1) CapacitorSF = PulseLaserSF
+updateRightParentSF LASER (LaserWeaponXSF x) BeamSplitterSF = LaserWeaponXSF (x+1)
 updateRightParentSF _ psf _ = psf
 
 leftChildList :: DTree CItem -> [ItemSF]

src/Dodge/Item/HeldOffset.hs

@@ -21,7 +21,8 @@ import qualified Quaternion as Q
 
 turretItemOffset :: Item -> Turret -> Machine -> Point3 -> Point3
 turretItemOffset it tu mc =
-    rotate3 (_tuDir tu + _mcDir mc) . (+.+.+ V3 0 0 shoulderHeight)
+    rotate3z (_tuDir tu + _mcDir mc) 
+        . (+ V3 0 0 shoulderHeight)
         . transToHandle it
 
 transToHandle :: Item -> Point3 -> Point3

src/Dodge/Item/Info.hs

@@ -183,6 +183,7 @@ craftInfo fit = case fit of
     MOTOR -> "A device that can create rotational force."
     TRANSFORMER -> "A device that can step up or down voltage and current."
     PRISM -> "An object that refracts light."
+    BEAMSPLITTER -> "Divides a single light beam into two paths."
     THERMOMETER -> "An object that measures temperature."
     LIGHTER -> "A device that can create a small flame."
     MAGNET -> "A device that attracts according to its dipoles."

src/Dodge/Item/InventoryColor.hs

@@ -38,7 +38,7 @@ sfInvColor = \case
     ProjectileStabiliserSF -> white
     UnderBarrelPlatformSF -> white
     UnderBarrelSlotSF -> white
-    LaserWeaponSF -> white
+--    LaserWeaponSF -> white
     PulseLaserSF -> white
     CapacitorSF -> yellow
     PulseBallSF -> white
@@ -46,6 +46,8 @@ sfInvColor = \case
     TransformerSF -> yellow
     PumpSF -> yellow
     TorchSF{} -> green
+    LaserWeaponXSF {} -> white
+    BeamSplitterSF {} -> white
 
 --ammoTypeColor :: AmmoType -> Color
 --ammoTypeColor = \case

src/Dodge/Item/Orientation.hs

@@ -80,7 +80,7 @@ itemShapeMin g = f . (^. _1) . itemSPic
 orientAttachment :: Item -> CItem -> Point3Q
 orientAttachment par (ch,chsf) = case (_itType par, chsf) of
     (ATTACH UNDERBARRELSLOT, _) -> (V3 (-5) (-8) 0, Q.qID)
-    (_,LaserWeaponSF) -> (V3 2 8 0, Q.qID)
+    (_,LaserWeaponXSF {}) -> (V3 2 8 0, Q.qID)
 --    (_,TorchSF) -> (V3 2 8 0, Q.qID)
     --    (HELD BURSTRIFLE, _, HELD TORCH) -> (V3 20 0 0, Q.axisAngle (V3 0 0 1) (pi/2))
     --    (HELD LAUNCHER, _, HELD TORCH) -> (V3 0 20 0, Q.axisAngle (V3 0 0 1) (pi/4))

src/Dodge/Item/Weapon/LaserPath.hs

@@ -65,7 +65,7 @@ refract phasev x y wl p
 reflectPulseLaserAlong ::
     Float -> Point2 -> Point2 -> World -> ([(Point2, Object)], [Point2])
 {-# INLINE reflectPulseLaserAlong #-}
-reflectPulseLaserAlong phasev sp ep w = f $ filter (isunshad . snd) $ crWlPbHit sp ep w
+reflectPulseLaserAlong phasev sp ep w = f $ filter (isunshad . snd) $ crWlPbHitZ 20 sp ep w
   where
     f = \case
         ((p, OWall wl) : _)

src/Dodge/Laser/Update.hs

@@ -1,4 +1,5 @@
-module Dodge.Laser.Update (updateLaser, drawLaser) where
+{-# LANGUAGE LambdaCase #-}
+module Dodge.Laser.Update (updateLaser, drawLaser, drawPulseLaser,ltToCol) where
 
 import Dodge.Damage
 import Control.Lens
@@ -17,7 +18,7 @@ updateLaser w pt =
                 thHit
                 w
         TargetingLaser itid -> w & pointerToItemID itid . itTargeting . itTgPos ?~ last ps
-    , drawLaser (_lpColor pt) (sp : ps)
+    , drawLaser (_lpType pt) (sp : ps)
     )
   where
     phasev = _lpPhaseV pt
@@ -26,9 +27,21 @@ updateLaser w pt =
     xp = sp +.+ 800 *.* unitVectorAtAngle dir
     (thHit, ps) = reflectLaserAlong phasev sp xp w
 
-drawLaser :: Color -> [Point2] -> Picture
+drawLaser :: LaserType -> [Point2] -> Picture
-drawLaser col =
+drawLaser lt =
     setLayer BloomLayer -- was nozwrite
         . setDepth 19.5
-        . color (brightX 10 1 col)
+        . color (brightX 10 1 (ltToCol lt))
+        . thickLine 3
+
+ltToCol :: LaserType -> Color
+ltToCol = \case
+    DamageLaser {} -> yellow
+    TargetingLaser {} -> green
+
+drawPulseLaser :: [Point2] -> Picture
+drawPulseLaser =
+    setLayer BloomLayer -- was nozwrite
+        . setDepth 19.5
+        . color (brightX 10 1 cyan)
         . thickLine 3

src/Dodge/LevelGen.hs

@@ -31,7 +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
+--    print $ gw ^. genInts
     return $ foldl' assignPushDoors w (w ^. cWorld . lWorld . doors)
 
 assignPushDoors :: World -> Door -> World

src/Dodge/LevelGen/PlacementHelper.hs

@@ -61,10 +61,6 @@ contToIDCont f _ = f . fromJust . _plMID
 jps0' :: PSType -> (Placement -> Maybe Placement) -> Maybe Placement
 jps0' pst = Just . Placement (PS (V2 0 0) 0) pst Nothing Nothing . const
 
-jps0PushPS :: PSType -> (Int -> Maybe Placement) -> Maybe Placement
-jps0PushPS pst f = Just . Placement (PSNoShiftCont (V2 0 0) 0) pst Nothing Nothing $
-    \_ plmnt -> f (fromJust $ _plMID plmnt) <&> plSpot .~ _plSpot plmnt
-
 ps0j :: PSType -> Placement -> Placement
 ps0j pst plmnt = Placement (PS (V2 0 0) 0) pst Nothing Nothing (\_ -> const $ Just plmnt)
 

src/Dodge/LockAndKey.hs

@@ -25,13 +25,13 @@ lockRoomMultiItems =
 
 lockRoomKeyItems :: [(Int -> State LayoutVars (MetaTree Room String), State LayoutVars ItemType)]
 lockRoomKeyItems =
---    [ (lasCenSensEdge, takeOne [LASER,HELD TESLACOIL, 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)]

src/Dodge/Machine/Update.hs

@@ -89,7 +89,7 @@ updateTurret rotSpeed mc w =
                 . mcType
                 . mctTurret
                 . tuDir
-                %~ ((subtract mcdir) . turnTo rotSpeed mcpos aimpos . (+mcdir))
+                %~ (subtract mcdir . turnTo rotSpeed mcpos aimpos . (+mcdir))
         | otherwise = id
     closeFireAngle = seesYou -- && angleVV (ypos -.- mcpos) (unitVectorAtAngle mcdir) < 1
     updateFiringStatus

src/Dodge/Placement/Instance/Button.hs

@@ -1,4 +1,8 @@
-module Dodge.Placement.Instance.Button where
+module Dodge.Placement.Instance.Button (
+    putLitButOnPos,
+    extTrigLitPos,
+    putLitButOnPosExtTrig,
+) where
 
 import Color
 import Control.Lens
@@ -8,71 +12,66 @@ import Dodge.LevelGen.PlacementHelper
 import Dodge.LevelGen.Switch
 import Dodge.LightSource
 import Dodge.Placement.Instance.LightSource
-import Dodge.PlacementSpot
+--import Dodge.PlacementSpot
 import Geometry
+import Shape
 
-triggerSwitchSPic :: Color -> Color -> PlacementSpot -> Placement
+--triggerSwitchSPic :: Color -> Color -> PlacementSpot -> Placement
-triggerSwitchSPic c1 c2 ps = psPtCont ps (PutTrigger False) $
+--triggerSwitchSPic c1 c2 ps = psPtCont ps (PutTrigger False) $
-    \tp ->
+--    \tp ->
-        Just $
+--        Just $
-            pContID
+--            pContID
-                ps
+--                ps
-                ( PutButton
+--                ( PutButton
-                    ( makeSwitch
+--                    ( makeSwitch
-                        c1 c2
+--                        c1
-                        (SetTrigger True $ trigid tp)
+--                        c2
-                        (SetTrigger False $ trigid tp)
+--                        (SetTrigger True $ trigid tp)
-                    )
+--                        (SetTrigger False $ trigid tp)
-                )
+--                    )
-                (const Nothing)
+--                )
-  where
+--                (const Nothing)
-    trigid tp = fromJust $ _plMID tp
+--  where
+--    trigid tp = fromJust $ _plMID tp
+--
+--triggerSwitchSPicLight :: Color -> Color -> PlacementSpot -> Placement
+--triggerSwitchSPicLight c1 c2 ps = psPtCont ps (PutTrigger False) $
+--    \tp -> Just $
+--        pContID atFstLnkOut (PutLS thels) $
+--            \lsid ->
+--                Just $
+--                    pContID
+--                        ps
+--                        (PutButton (makeSwitch c1 c2 (oneff lsid $ trigid tp) (offeff lsid $ trigid tp)))
+--                        (const Nothing)
+--  where
+--    thels = lsColPosRad (V3 0.5 0 0) (V3 0 0 78) 75
+--    trigid tp = fromJust $ _plMID tp
+--    oneff lsid tid = WorldEffects [SetLSCol (V3 0 0.5 0) lsid, SetTrigger True tid]
+--    offeff lsid tid = WorldEffects [SetLSCol (V3 0.5 0 0) lsid, SetTrigger False tid]
 
-triggerSwitchSPicLight :: Color -> Color -> PlacementSpot -> Placement
+--triggerSwitch :: Color -> PlacementSpot -> Placement
-triggerSwitchSPicLight c1 c2 ps = psPtCont ps (PutTrigger False) $
+--triggerSwitch col ps = psPtCont ps (PutTrigger False) $
-    \tp -> Just $
+--    \tp ->
-        pContID atFstLnkOut (PutLS thels) $
+--        Just $
-            \lsid ->
+--            pContID
-                Just $
+--                ps
-                    pContID
+--                (PutButton (makeSwitch col col (SetTrigger True $ trigid tp) (SetTrigger False $ trigid tp)))
-                        ps
+--                (const Nothing)
-                        (PutButton (makeSwitch c1 c2 (oneff lsid $ trigid tp) (offeff lsid $ trigid tp)))
+--  where
-                        (const Nothing)
+--    trigid tp = fromJust $ _plMID tp
-  where
-    thels = lsColPosRad (V3 0.5 0 0) (V3 0 0 78) 75
-    trigid tp = fromJust $ _plMID tp
-    oneff lsid tid = WorldEffects [SetLSCol (V3 0 0.5 0) lsid, SetTrigger True tid]
-    offeff lsid tid = WorldEffects [SetLSCol (V3 0.5 0 0) lsid, SetTrigger False tid]
-
-triggerSwitch :: Color -> PlacementSpot -> Placement
-triggerSwitch col ps = psPtCont ps (PutTrigger False) $
-    \tp ->
-        Just $
-            pContID
-                ps
-                ( PutButton
-                    ( makeSwitch
-                        col
-                        col
-                        (SetTrigger True $ trigid tp)
-                        (SetTrigger False $ trigid tp)
-                    )
-                )
-                (const Nothing)
-  where
-    trigid tp = fromJust $ _plMID tp
 
 putLitButOnPos :: Color -> PlacementSpot -> (Placement -> Maybe Placement) -> Placement
 putLitButOnPos col theps subpl =
     plSpot .~ theps $
-        mntLSOn aShape (Just col) ls 0 (V3 0 (-40) 40) $
+        mntLSOn shp ls 0 (V3 0 (-40) 40) $
-            \plmnt ->
+            \pmnt ->
                 jps0'
-                    (PutButton (makeButton col (changeLight . fromJust $ _plMID plmnt)){_btPos = V2 0 (-1), _btRot = pi})
+                    (PutButton (makeButton col (changeLight $ pmnt ^?! plMID . _Just) & btPos .~ V2 0 (-1) & btRot .~ pi))
                     subpl
-                    <&> plSpot
+                    <&> plSpot .~ _plSpot pmnt
-                    .~ _plSpot plmnt
   where
+    shp = fmap (fmap $ colorSH col) aShape
     changeLight = SetLSCol (V3 0 0.5 0)
     ls = lsColPosRad (V3 0.5 0 0) (V3 0 0 50) 50
 
@@ -107,20 +106,20 @@ putLitButOnPosExtTrig' col thePS cnt =
     psPtCont thePS (PutTrigger False) $
         \tp -> Just $
             plSpot .~ _plSpot tp $
-                mntLSOn aShape (Just col) ls 0 (V3 0 (-40) 40) $
+                mntLSOn shp ls 0 (V3 0 (-40) 40) $
                     \plmnt ->
                         jps0'
                             ( PutButton
-                                (makeButton col (WorldEffects [changeLight (fromJust $ _plMID plmnt), oneff (trigid tp)]))
+                                (makeButton col (buteff (trigid tp) (fromJust $ _plMID plmnt)))
                                     { _btPos = V2 0 (-1)
                                     , _btRot = pi
                                     }
                             )
                             (cnt tp plmnt)
                             <&> plSpot
-                            .~ _plSpot plmnt
+                                .~ _plSpot plmnt
   where
+    buteff i j = SetTriggerAndSetLSCol True i (V3 0 0.5 0) j
+    shp = fmap (fmap $ colorSH col) aShape
     trigid tp = fromJust $ _plMID tp
-    oneff = SetTrigger True
-    changeLight = SetLSCol (V3 0 0.5 0)
     ls = lsColPosRad (V3 0.5 0 0) (V3 0 0 50) 50

src/Dodge/Placement/Instance/Door.hs

@@ -14,78 +14,55 @@ import Dodge.LevelGen.PlacementHelper
 import Geometry
 import Linear
 
-putDoubleDoor :: Wall -> WdBl -> Point2 -> Point2 -> Float -> Placement
+putDoubleDoor :: Wall -> Point2 -> Point2 -> Door -> Placement
-putDoubleDoor wl cond a b speed =
+putDoubleDoor wl a b dr = putDoubleDoorThen wl 1 a b dr (const $ const Nothing)
-    putDoubleDoorThen wl cond 1 a b speed (const $ const Nothing)
 
 putDoubleDoorThen ::
     Wall ->
-    WdBl ->
     Float ->
     Point2 ->
     Point2 ->
-    Float ->
+    Door ->
     (Placement -> Placement -> Maybe Placement) ->
     Placement
-putDoubleDoorThen wl cond soff a b speed cont =
+putDoubleDoorThen wl soff a b dr cont =
-    doorBetween wl cond soff a half speed $
+    doorBetween wl soff a half dr $
-        \pl1 -> Just $
+        \pl1 -> Just $ doorBetween wl soff b half dr $ \pl2 -> cont pl1 pl2
-            doorBetween wl cond soff b half speed $
-                \pl2 -> cont pl1 pl2
   where
     half = 0.5 *^ (a + b)
 
 doorBetween ::
     Wall ->
-    WdBl ->
     Float ->
     Point2 ->
     Point2 ->
-    Float ->
+    Door ->
     (Placement -> Maybe Placement) ->
     Placement
-doorBetween wl cond soff pa pb speed g = case divideLine 40 pa pb of
+doorBetween wl soff pa pb dr g = case divideLine 40 pa pb of
---    [x, y] -> ptCont (putSlideDr adoor wl soff x y) g
     (x : y : zs) ->
-        divideDoorPane
+        divideDoorPane Nothing wl (soff - dist y pb) dr (zip (x : y : zs) (y : zs)) g
-            Nothing
-            wl
-            cond
-            (soff - dist y pb)
-            speed
-            (zip (x : y : zs) (y : zs))
-            g
     _ -> error "tried to create doorBetween with too few points"
---  where
---    adoor =
---        defaultDoor
---            & drTrigger .~ cond
---            & drUpdate .~ DoorLerp speed
 
 divideDoorPane ::
     Maybe Int ->
     Wall ->
-    WdBl ->
-    Float ->
     Float ->
+    Door ->
     [(Point2, Point2)] ->
     (Placement -> Maybe Placement) ->
     Placement
-divideDoorPane mid wl cond soff speed ppairs g = case ppairs of
+divideDoorPane mid wl soff dr ppairs g = case ppairs of
     [p] -> ptCont (adoor p) g
     (p : ps) -> ptCont (adoor p) $
-        \pl -> Just $ divideDoorPane (_plMID pl) wl cond soff speed ps g
+        \pl -> Just $ divideDoorPane (_plMID pl) wl soff dr ps g
     _ -> undefined
   where
     adoor (x, y) = putSlideDr thedoor wl soff x y
-    thedoor =
+    thedoor = dr & drPushedBy .~ maybe PushesItself PushedBy mid
-        defaultDoor
-            & drUpdate . drLerpSpeed .~ speed
-            & drTrigger .~ cond
-            & drPushedBy .~ maybe PushesItself PushedBy mid
 
 putAutoDoor :: Point2 -> Point2 -> Placement
-putAutoDoor a b = Placement (PS 0 0) (PutCoord a) Nothing Nothing $ \_ apl ->
+putAutoDoor a b = pt0 (PutCoord a) $ \apl ->
     Just $
         Placement (PS 0 0) (PutCoord b) Nothing Nothing $ \w bpl ->
             let x = w ^?! gwWorld . coordinates . ix (apl ^?! plMID . _Just)
@@ -93,7 +70,9 @@ putAutoDoor a b = Placement (PS 0 0) (PutCoord a) Nothing Nothing $ \_ apl ->
              in Just $
                     putDoubleDoor
                         defaultAutoWall
-                        (WdBlCrFilterNearPoint 40 (0.5 *^ (x + y)) CrIsAnimate)
                         a
                         b
-                        3
+                        ( defaultDoor
+                            & drTrigger .~ WdBlCrFilterNearPoint 40 (0.5 *^ (x + y)) CrOpenAutoDoor
+                            & drUpdate .~ DoorLerpWithTimer 0 3
+                        )

src/Dodge/Placement/Instance/LightSource.hs

@@ -36,21 +36,22 @@ mntLSOn ::
     -- | function describing the mount shape
     (Point2 -> Point3 -> Shape) ->
     -- | describing a possible color override for the shape
-    Maybe Color ->
     LightSource ->
     Point2 ->
     Point3 ->
     (Placement -> Maybe Placement) ->
     Placement
-mntLSOn shapeF mcol ls wallp lsp@(V3 lx ly _) =
+mntLSOn shapeF ls wallp lsp@(V3 lx ly _) =
     ps0jPushPS (PutLabel "light") .
-    ps0jPushPS (putShape . setCol $ shapeF wallp lsp)
+    ps0jPushPS (putShape $ shapeF wallp lsp)
+    --ps0j (PutLabel "light") .
+    --ps0j (putShape $ shapeF wallp lsp)
         . pt0 (PutLS $ ls & lsParam . lsPos .~ lsp')
   where
     lsp' = lsp -.-.- V3 x y 1
     -- hack! perturb the light position
     V2 x y = rotateV 1 . (0.1 *.*) . normalizeV $ wallp -.- V2 lx ly
-    setCol = maybe id colorSH mcol
+--    setCol = maybe id colorSH mcol
 
 iShape :: Point2 -> Point3 -> Shape
 iShape wp (V3 x y z) = thinHighBar z wp (V2 x y)
@@ -95,38 +96,17 @@ aShape wallpos (V3 x y z) = girder (z + 2) 20 10 pout wallpos
     pout = V2 x y -.- 2 *.* squashNormalizeV (V2 x y -.- wallpos)
 
 vShape :: Point2 -> Point3 -> Shape
-vShape wallpos (V3 x y z) =
+vShape p (V3 x y z) = abar n <> abar (-n)
-    thinHighBar z wallposUp lxy
-        <> thinHighBar z wallposDown lxy
   where
+    abar a = thinHighBar z (p + a) lxy
     lxy = V2 x y
-    n = vNormal (wallpos -.- lxy)
+    n = vNormal (p - lxy)
-    wallposUp = wallpos +.+ n
-    wallposDown = wallpos -.- n
 
 mntLS :: (Point2 -> Point3 -> Shape) -> Point2 -> Point3 -> Placement
-mntLS shp wallp lampp = mntLSOn shp Nothing defaultLS wallp lampp (const Nothing)
+mntLS shp wallp lampp = mntLSOn shp defaultLS wallp lampp (const Nothing)
   where
     defaultLS = LS 0 $ LSParam 0 300 0.6
 
---mntLSCol :: (Point2 -> Point3 -> Shape) -> Color -> Point2 -> Point3 -> Placement
---mntLSCol shp col wallp lampp = mntLSOn shp (Just col) defaultLS wallp lampp (const Nothing)
---  where
---    defaultLS = LS 0 $ LSParam 0 200 0.6
-
---mntLSLampCol :: (Point2 -> Point3 -> Shape) -> Color -> Point2 -> Point3 -> Placement
---mntLSLampCol shp (V4 x y z _) wallp lampp =
---    mntLSOn
---        shp
---        Nothing
---        (defaultLS & lsParam . lsCol .~ col)
---        wallp
---        lampp
---        (const Nothing)
---  where
---    col = V3 x y z
---    defaultLS = LS 0 $ LSParam 0 200 0.6
-
 mntLSCond ::
     (Point2 -> Point3 -> Shape) ->
     --    -> (RoomPos -> Room -> Maybe (PlacementSpot,RoomPos))
@@ -150,7 +130,7 @@ mntLightLnkCond ps = do
     return $ mntLSCond (fmap (fmap $ colorSH black) shp) ps
 
 mntLightLnkShape :: (Point2 -> Point3 -> Shape) -> PlacementSpot -> Placement
-mntLightLnkShape shp ps = mntLSCond (fmap (fmap $ colorSH black) shp) ps
+mntLightLnkShape shp = mntLSCond (fmap (fmap $ colorSH black) shp)
 
 mntLightLnkCond' :: PlacementSpot -> Placement
 mntLightLnkCond' = mntLSCond (fmap (fmap $ colorSH black) vShape)

src/Dodge/Placement/PlaceSpot.hs

@@ -1,12 +1,12 @@
---{-# LANGUAGE LambdaCase #-}
+-- {-# LANGUAGE LambdaCase #-}
---{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
+-- {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
 
 {- | deals with placement of objects within the world
  after they have had their coordinates set by the layout
 -}
 module Dodge.Placement.PlaceSpot (placeSpot) where
 
---import Control.Monad.State
+-- import Control.Monad.State
 import Control.Monad.Trans.State.Lazy
 import Data.Bifunctor
 import Data.Foldable
@@ -57,9 +57,7 @@ placePlainPSSpot w rid plmnt shift = case plmnt ^. plType of
         j <- x ^. plExternalID
         return $ gw & genPmnt . at j ?~ x
     recrPlace newplmnt w' =
-        placeSpot
+        placeSpot rid (w' & genRooms . ix rid . rmPmnts .:~ newplmnt)
-            rid
-            (w' & genRooms . ix rid . rmPmnts .:~ newplmnt)
 
 -- this should be tidied up
 placeSpotUsingRoomPos ::
@@ -94,7 +92,7 @@ placeSpotRoomRand ::
 placeSpotRoomRand rid i f plmnt w =
     let (ps, g) =
             runState
-                (_rmRandPSs (w ^?! genRooms . ix rid) !! i)
+                (w ^?! genRooms . ix rid . rmRandPSs . ix i)
                 $ w ^. gwWorld . randGen
      in placeSpot rid (w & gwWorld . randGen .~ g) (plmnt & plSpot .~ f ps)
 
@@ -102,62 +100,69 @@ placeSpotRoomRand rid i f plmnt w =
 placeSpotID :: Int -> PlacementSpot -> PSType -> GenWorld -> (Int, GenWorld)
 placeSpotID rid ps pt w = case pt of
     PutTrigger cnd -> plNewID (gwWorld . cWorld . lWorld . triggers) cnd w
-    PutMod mdi -> plNewUpID (gwWorld . cWorld . lWorld . modifications) mdID mdi w
+    PutMod mdi ->
-    PutProp prp -> plNewUpID (gwWorld . cWorld . lWorld . props) prID (mvProp p rot prp) w
+        plNewUpID (gwWorld . cWorld . lWorld . modifications) mdID mdi w
+    PutProp prp ->
+        plNewUpID (gwWorld . cWorld . lWorld . props) prID (mvProp p rot prp) w
     PutButton bt ->
-        plNewUpID
+        plNewUpID (gwWorld . cWorld . lWorld . buttons) btID (mvButton p rot bt) w
-            (gwWorld . cWorld . lWorld . buttons)
-            btID
-            (mvButton p rot bt)
-            w
     PutTerminal tm -> plNewUpID (gwWorld . cWorld . lWorld . terminals) tmID tm w
     PutFlIt itm ->
         let i = IM.newKey (w ^. gwWorld . cWorld . lWorld . items)
          in ( i
             , w
-                & gwWorld . cWorld . lWorld . floorItems . at i ?~ FlIt p rot
+                & gwWorld
-                & gwWorld . cWorld . lWorld . items . at i
+                . cWorld
-                    ?~ ( itm & itID .~ NInt i
+                . lWorld
-                            & itLocation .~ OnFloor
+                . floorItems
-                       )
+                . at i
+                ?~ FlIt p rot
+                & gwWorld
+                . cWorld
+                . lWorld
+                . items
+                . at i
+                ?~ (itm & itID .~ NInt i & itLocation .~ OnFloor)
             )
     PutCrit cr -> plNewUpID (gwWorld . cWorld . lWorld . creatures) crID (mvCr p rot cr) w
     PutForeground fs ->
         (0, w & gwWorld . cWorld . lWorld . foreShapes .:~ mvFS p rot fs)
     PutMachine pps mc mitm -> plMachine (map doShift pps) mc mitm p rot w
-    PutLS ls -> plNewUpID (gwWorld . cWorld . lWorld . lightSources) lsID (mvLS p' rot ls) w
+    PutLS ls -> plNewUpID (gwWorld . cWorld . lWorld . lightSources) lsID (mvLS p rot ls) w
-    RandPS _ -> error "RandPS should not be reachable here" --evaluateRandPS rid rgn ps w
+    RandPS _ -> error "RandPS should not be reachable here" -- evaluateRandPS rid rgn ps w
     PutDoor dr wl -> plDoor (dr & drZeroPos %~ pashift & drOnePos %~ pashift) wl w
     PutCoord cp -> plNewID (gwWorld . coordinates) (doShift cp) w
     PutBlock bl wl ps' ->
-        plBlock
+        plBlock (map doShift ps') (bl & blPos %~ doShift & blDir .~ rot) wl w
-            (map doShift ps')
-            (bl & blPos %~ doShift & blDir .~ rot)
-            wl
-            w
     PutLineBlock wl wdth a b -> plLineBlock wl wdth (doShift a) (doShift b) w
     PutWall qs wl -> (0, over gwWorld (placeWallPoly (map doShift qs) wl) w)
     PutNothing -> (0, w)
     PutID i -> (i, w)
     PutWorldUpdate f -> (0, w & f rid ps)
-    PutChasm ps' qs -> (0, placeChasm w rid ps' (map (map doShift) ps') 
+    PutChasm ps' qs ->
-        (foldMap loopPairs (map (map doShift) qs)))
+        ( 0
+        , placeChasm
+            rid
+            ps'
+            (map (map doShift) ps')
+            (foldMap (loopPairs . map doShift) qs)
+            w
+        )
     PutLabel{} -> (0, w)
   where
-    p@(V2 px py) = _psPos ps
+    p = _psPos ps
-    p' = V3 px py 0
     rot = _psRot ps
     doShift = shiftPointBy (p, rot)
     pashift = compP2A (p, rot)
 
-placeChasm :: GenWorld -> Int -> [[Point2]] -> [[Point2]] -> [(Point2,Point2)] -> GenWorld
+placeChasm :: Int -> [[Point2]] -> [[Point2]] -> [(Point2, Point2)] -> GenWorld -> GenWorld
-placeChasm gw rid ps shiftps cfs =
+placeChasm rid ps shiftps cfs =
-    gw & gwWorld . cWorld . chasms <>~ shiftps
+    (gwWorld . cWorld . chasms <>~ shiftps)
-        & gwWorld . cWorld . cliffs <>~ cfs
+        . (gwWorld . cWorld . cliffs <>~ cfs)
-        & genRooms . ix rid . rmPos %~ filter (\rp -> not $ any (pointInPoly (_rpPos rp)) ps)
+        . (genRooms . ix rid . rmPos %~ filter (\rp -> not $ any (pointInPoly (_rpPos rp)) ps))
-        & gwWorld %~ f
+        . (gwWorld %~ f)
   where
-    --f w = foldl' g w (loopPairs shiftps)
+    -- f w = foldl' g w (loopPairs shiftps)
     f w = foldl' g w cfs
     g w (x, y) = obstructPathsCrossing (S.singleton ChasmObstacle) x y w
 
@@ -172,19 +177,16 @@ addPane wl w l = insertWall (wl & wlLine .~ l & wlID .~ i) w
     i = IM.newKey $ w ^. cWorld . lWorld . walls
 
 mvProp :: Point2 -> Float -> Prop -> Prop
-mvProp p a = (prRot +~ a) . (prPos %~ ((p +.+) . rotateV a))
+mvProp p a = (prRot +~ a) . (prPos %~ ((p +) . rotateV a))
 
 mvButton :: Point2 -> Float -> Button -> Button
-mvButton p a = (btRot +~ a) . (btPos %~ ((p +.+) . rotateV a))
+mvButton p a = (btRot +~ a) . (btPos %~ ((p +) . rotateV a))
 
 mvCr :: Point2 -> Float -> Creature -> Creature
-mvCr p rot =
+mvCr p rot = (crPos . _xy .~ p) . (crOldPos . _xy .~ p) . (crDir .~ rot)
-    (crPos . _xy .~ p)
-        . (crOldPos . _xy .~ p)
-        . (crDir .~ rot)
 
 mvFS :: Point2 -> Float -> ForegroundShape -> ForegroundShape
-mvFS p a = (fsDir +~ a) . (fsPos %~ ((p +.+) . rotateV a))
+mvFS p a = (fsDir +~ a) . (fsPos %~ ((p +) . rotateV a))
 
 plMachine ::
     [Point2] ->
@@ -196,9 +198,15 @@ plMachine ::
     (Int, GenWorld)
 plMachine wallpoly mc mitm p rot gw =
     ( mcid
-    , gw & tolw . machines . at mcid ?~ themc
+    , gw
-        & gwWorld %~ placeMachineWalls (_mcMaterial mc) wallpoly mcid wlid
+        & tolw
-        & tolw %~ maybe id placeturretitm mitm
+        . machines
+        . at mcid
+        ?~ themc
+        & gwWorld
+        %~ placeMachineWalls (_mcMaterial mc) wallpoly mcid wlid
+        & tolw
+        %~ maybe id placeturretitm mitm
     )
   where
     tolw = gwWorld . cWorld . lWorld
@@ -216,10 +224,13 @@ plMachine wallpoly mc mitm p rot gw =
 placeMachineWalls :: Material -> [Point2] -> Int -> Int -> World -> World
 placeMachineWalls mat poly mcid = insertStructureWalls MachinePart baseWall poly mcid
   where
-    baseWall = defaultMachineWall & wlStructure . wsMachine .~ mcid
+    baseWall =
-        & wlMaterial .~ mat
+        defaultMachineWall
+            & wlStructure
+            . wsMachine
+            .~ mcid
+            & wlMaterial
+            .~ mat
 
-mvLS :: Point3 -> Float -> LightSource -> LightSource
+mvLS :: Point2 -> Float -> LightSource -> LightSource
-mvLS (V3 x y z) rot ls = ls & lsParam . lsPos .~ V3 x y z + startPos
+mvLS x rot = lsParam . lsPos . _xy %~ ((+ x) . rotateV rot)
-  where
-    startPos = onXY (rotateV rot) $ _lsPos (_lsParam ls)

src/Dodge/Render/Lights.hs

@@ -1,6 +1,4 @@
-module Dodge.Render.Lights (
+module Dodge.Render.Lights (lightsToRender) where
-    lightsToRender,
-) where
 
 import Data.List (sortOn)
 import Data.Maybe

src/Dodge/Render/Picture.hs

@@ -115,7 +115,7 @@ mouseCursorType u = case u ^. uvWorld . input . mouseContext of
     OverCombEscape -> rotate (pi / 4) $ drawPlus 5
     OverTerminal _ ts -> drawCursorByTerminalStatus ts
     OutsideTerminal -> rotate (pi / 4) $ drawPlus 5
-    MouseGameRotate -> rotate a (drawVerticalDoubleArrow 5)
+    MouseGameRotate {} -> rotate a (drawVerticalDoubleArrow 5)
     OverDebug {} -> drawPlus 5 <> rotate (pi/4) (drawPlus 5)
     --OverDebug db i -> scale 0.1 0.1 $ text (show db ++ show i)
   where

src/Dodge/Render/ShapePicture.hs

@@ -37,7 +37,7 @@ worldSPic cfig u =
                 (lw ^. items)
                 (filtOn _flItPos _floorItems)
             )
-        <> foldup btSPic (filtOn _btPos _buttons)
+        <> foldup (btSPic (w ^. cWorld . lWorld)) (filtOn _btPos _buttons)
         <> foldup (mcSPic (w ^. cWorld)) (filtOn _mcPos _machines)
 --        <> foldMap' drawChasm (w ^. cWorld . chasms)
         <> foldMap' (Prelude.uncurry drawCliff) (w ^. cWorld . cliffs)
@@ -166,8 +166,8 @@ floorItemSPic itm flit =
             (_flItRot flit)
             (itemSPic itm)
 
-btSPic :: Button -> SPic
+btSPic :: LWorld -> Button -> SPic
-btSPic bt = uncurryV translateSPxy (_btPos bt) $ rotateSP (_btRot bt) (drawButton bt)
+btSPic lw bt = uncurryV translateSPxy (_btPos bt) $ rotateSP (_btRot bt) (drawButton lw bt)
 
 mcSPic :: CWorld -> Machine -> SPic
 mcSPic cw mc = uncurryV translateSPxy (_mcPos mc) $ rotateSP (_mcDir mc) (drawMachine cw mc)

src/Dodge/Room/Airlock.hs

@@ -26,8 +26,7 @@ import ShapePicture
 
 -- | A passage with a switch that opens forward access while closing backwards access.
 airlock :: RandomGen g => State g Room
-airlock =
+airlock = join $
-    join $
         takeOne [return airlock0, return airlock90, return airlockCrystal, airlockZ]
 
 xSwitch :: PSType
@@ -44,8 +43,8 @@ decontamRoom i =
         & rmPmnts
             .~ [ pContID (PS (V2 (-35) 50) (negate $ pi / 2)) xSwitch $
                     \btid -> Just $
-                        putDoubleDoorThen defaultDoorWall (WdBlNegate $ WdBlBtOn btid) 1 (V2 0 20) (V2 40 20) 2 $
+                        putDoubleDoorThen defaultDoorWall 1 (V2 0 20) (V2 40 20) (dr1 btid) $
-                            \_ _ -> Just $ putDoubleDoor defaultDoorWall (WdBlBtOn btid) (V2 0 80) (V2 40 80) 2
+                            \_ _ -> Just $ putDoubleDoor defaultDoorWall (V2 0 80) (V2 40 80) (dr2 btid)
                , invisibleWall $ rectNSWE 60 40 (-40) (-30)
                , spanLightI (V2 (-20) 30) (V2 (-20) 70)
                , analyser (NoItemZone ps) (PS 50 0) (PS mcpos 0) & plExternalID ?~ i
@@ -55,15 +54,16 @@ decontamRoom i =
         & rmInPmnt .~ [(0, return . f)]
         & rmBound .~ [rectNSWE 75 15 0 40, switchcut]
   where
+    dr1 btid = defaultDoor & drTrigger .~ WdBlNegate (WdBlBtOn btid)
+    dr2 btid = defaultDoor & drTrigger .~ WdBlBtOn btid
     f gw = fromMaybe (error "tried to put a door using an empty placement list") $ do
         pmnt <- gw ^? genPmnt . ix i
         return $
             putDoubleDoor
                 defaultDoorWall
-                (cond pmnt)
                 (V2 (-10) 35)
                 (V2 (-10) 65)
-                2
+                (defaultDoor & drTrigger .~ cond pmnt)
     cond pmnt = WdTrig $ pmnt ^?! plMID . _Just
     mcpos = V2 70 50
     cutps = [rectNSWE 100 0 0 40, switchcut]
@@ -84,15 +84,17 @@ airlock0 =
         , _rmPmnts =
             [ pContID (PS (V2 (-35) 50) (negate $ pi / 2)) xSwitch $
                 \btid -> Just $
-                    putDoubleDoorThen defaultDoorWall (WdBlNegate $ WdBlBtOn btid) 1 (V2 0 20) (V2 40 20) 2 $
+                    putDoubleDoorThen defaultDoorWall 1 (V2 0 20) (V2 40 20) (dr1 btid) $
-                        \_ _ -> Just $ putDoubleDoor defaultDoorWall (WdBlBtOn btid) (V2 0 80) (V2 40 80) 2
+                        \_ _ -> Just $ putDoubleDoor defaultDoorWall (V2 0 80) (V2 40 80) (dr2 btid)
             , invisibleWall $ rectNSWE 60 40 (-40) (-30)
             , spanLightI (V2 (-2) 30) (V2 (-2) 70)
-            , sps0 $ putShape $ thinHighBar 75 (V2 40 50) (V2 (-1) 50)
+            , sps0 $ putShape $ thinHighBar 95 (V2 40 50) (V2 (-1) 50)
             ]
         , _rmBound = [rectNSWE 75 15 0 40, switchcut]
         }
   where
+    dr1 btid = defaultDoor & drTrigger .~ WdBlNegate (WdBlBtOn btid)
+    dr2 btid = defaultDoor & drTrigger .~ WdBlBtOn btid
     switchcut = rectNSWE 65 35 (-40) 20
     lnks =
         [ (V2 20 95, 0)

src/Dodge/Room/Door.hs

@@ -1,6 +1,7 @@
 {- Rooms that connect other rooms, blocking sight.  -}
 module Dodge.Room.Door where
 
+import Dodge.Default.Door
 import Dodge.Default.Wall
 import Data.Maybe
 import Dodge.Data.GenWorld
@@ -42,5 +43,6 @@ triggerDoorRoom i =
   where
     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
+        return $ putDoubleDoor defaultDoorWall (V2 0 20) (V2 40 20)
+            (defaultDoor & drTrigger .~ cond pmnt)
     cond pmnt = WdTrig $ fromJust (_plMID pmnt)

src/Dodge/Room/Foreground.hs

@@ -121,7 +121,7 @@ girderZ h d w x y =
             [ thinHighBar h xt yt
             , thinHighBar h xb yb
             ]
-                <> zipWith (thinHighBar (h )) ps qs
+                <> zipWith (thinHighBar (h-1)) ps qs
   where
     n = w *.* normalizeV (vNormal $ y -.- x)
     xb = x +.+ n

src/Dodge/Room/LasTurret.hs

@@ -49,7 +49,7 @@ import Shape
 
 -- no lights!
 cenLasTur :: (RandomGen g) => State g Room
-cenLasTur = do
+cenLasTur =
     roomNgon 8 200
         <&> rmPmnts
         .~ [ putLasTurret 0.02
@@ -168,7 +168,7 @@ lasCenSensEdge n = do
     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 cenroom = cenroom' & rmInPmnt <>~ map blight [pi, 0.5 * pi, 1.5 * pi]
     let doorroom = triggerDoorRoom n
     rToOnward "lasCenSensEdge" $
         treeFromTrunk [door] $
@@ -194,7 +194,7 @@ lasRunYinYang = do
                 const
                     . ( \rp ->
                             PolyEdge ((npoly + 1) `div` 4)
-                                `S.member` (fold $ rp ^? rpType . rplsType)
+                                `S.member` fold (rp ^? rpType . rplsType)
                       )
     thelight3 <-
         mntLightLnkCond $
@@ -202,7 +202,7 @@ lasRunYinYang = do
                 const
                     . ( \rp ->
                             PolyEdge (3 * (npoly + 1) `div` 4)
-                                `S.member` (fold $ rp ^? rpType . rplsType)
+                                `S.member` fold (rp ^? rpType . rplsType)
                       )
     r <-
         shuffleLinks
@@ -231,16 +231,16 @@ lasRunYinYang = do
                 )
     rToOnward "lasCenRunClose" $ return $ cleatOnward r
   where
-    awall x v = heightWallPS (PS x 0) 30 v
+    awall x = heightWallPS (PS x 0) 30
     -- 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)) (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))
       where
         a = a' + pi / 16
         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))) (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)))
       where
         a = a' + pi / 16
@@ -257,7 +257,7 @@ lasRunYinYangCenter = do
                 const
                     . ( \rp ->
                             PolyEdge ((npoly + 1) `div` 4)
-                                `S.member` (fold $ rp ^? rpType . rplsType)
+                                `S.member` fold (rp ^? rpType . rplsType)
                       )
     thelight3 <-
         mntLightLnkCond $
@@ -265,7 +265,7 @@ lasRunYinYangCenter = do
                 const
                     . ( \rp ->
                             PolyEdge (3 * (npoly + 1) `div` 4)
-                                `S.member` (fold $ rp ^? rpType . rplsType)
+                                `S.member` fold (rp ^? rpType . rplsType)
                       )
     --    thelight3 <- mntLightLnkCond $ rprBool $ const . isOutLnk
     r <-
@@ -293,14 +293,14 @@ lasRunYinYangCenter = do
                 )
     rToOnward "lasCenRunClose" $ return $ cleatOnward r
   where
-    awall x v = heightWallPS (PS x 0) 30 v
+    awall x = heightWallPS (PS x 0) 30
     -- 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)) (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))
       where
         a = a' + pi / 16
         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))) (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)))
       where
         a = a' + pi / 16
@@ -334,24 +334,24 @@ lasCenRunClose' = do
     rToOnward "lasCenRunClose" $ return $ cleatOnward r
   where
     swall =
-        [ (70, (rectNSWE 10 (-10) (-10) 30))
+        [ (70, rectNSWE 10 (-10) (-10) 30)
-        , (125, (rectNSWE 55 (-55) (-10) 10))
+        , (125, rectNSWE 55 (-55) (-10) 10)
-        , (180, (rectNSWE 10 (-10) (-30) 10))
+        , (180, rectNSWE 10 (-10) (-30) 10)
         ]
     zwall =
-        [ (70, (rectNSWE 10 (-10) (-30) 10))
+        [ (70, rectNSWE 10 (-10) (-30) 10)
-        , (125, (rectNSWE 55 (-55) (-10) 10))
+        , (125, rectNSWE 55 (-55) (-10) 10)
-        , (180, (rectNSWE 10 (-10) (-10) 30))
+        , (180, rectNSWE 10 (-10) (-10) 30)
         ]
     iwall =
-        [ (70, (rectNSWE 10 (-10) (-15) 20))
+        [ (70, rectNSWE 10 (-10) (-15) 20)
-        , (180, (rectNSWE 10 (-10) (-30) (-5)))
+        , (180, rectNSWE 10 (-10) (-30) (-5))
         ]
     jwall =
-        [ (70, (rectNSWE 10 (-10) (-20) 15))
+        [ (70, rectNSWE 10 (-10) (-20) 15)
-        , (180, (rectNSWE 10 (-10) 5 30))
+        , (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]
     linkwall f x =
         heightWallPS
@@ -390,7 +390,7 @@ lasCenRunCloseLongCor = do
   where
     llinks = memtest (FromEdge South 1) (OnEdge West)
     rlinks = memtest (FromEdge South 1) (OnEdge East)
-    awall x v = heightWallPS (PS x 0) 30 v
+    awall x = heightWallPS (PS x 0) 30
     memtest a b x =
         let y = _rlType x
          in a `S.member` y && b `S.member` y
@@ -459,7 +459,7 @@ lasCenRunClose1 = do
         etest
             (memtest (FromEdge East 0) (OnEdge South))
             (memtest (FromEdge South 0) (OnEdge East))
-    awall x v = heightWallPS (PS x 0) 30 v
+    awall x = heightWallPS (PS x 0) 30
     etest f g x = f x || g x
     memtest a b x =
         let y = _rlType x
@@ -500,7 +500,7 @@ lasCenRunClose2 = do
         etest
             (memtest (FromEdge East 0) (OnEdge North))
             (memtest (FromEdge North 0) (OnEdge East))
-    awall x v = heightWallPS (PS x 0) 30 v
+    awall x = heightWallPS (PS x 0) 30
     etest f g x = f x || g x
     memtest a b x =
         let y = _rlType x

src/Dodge/Room/LongDoor.hs

@@ -3,6 +3,9 @@
 -- | Rooms containing long doors, probably with a big reveal behind them.
 module Dodge.Room.LongDoor where
 
+import Dodge.Room.Modify
+import qualified Data.IntMap.Strict as IM
+import Dodge.Default
 import Control.Monad
 import Data.Maybe
 import qualified Data.Set as S
@@ -11,7 +14,6 @@ import Dodge.Creature
 import Dodge.Data.GenWorld
 import Dodge.Default.Door
 import Dodge.Default.Room
-import Dodge.Default.Wall
 import Dodge.Door.PutSlideDoor
 import Dodge.LevelGen.PlacementHelper
 import Dodge.LevelGen.Switch
@@ -64,7 +66,6 @@ twinSlowDoorRoom w h x =
   where
     --thewall = switchWallCol red
     thewall = defaultDoorWall
-    wlSpeed = 0.5
     lampheight = 41
     ps =
         [ rectNSWE h 0 (- w) w
@@ -72,7 +73,7 @@ twinSlowDoorRoom w h x =
         ]
     thedoor btid =
         defaultDoor
-            & drUpdate . drLerpSpeed .~ wlSpeed
+            & drUpdate . drLerpSpeed .~ 0.5
             & drTrigger .~ WdBlBtOn btid
     col = dim $ dim $ bright red
 
@@ -116,11 +117,11 @@ addButtonSlowDoor x h =
         $ \btplmnt -> Just
             . putDoubleDoorThen
                 defaultDoorWall
-                (WdBlBtOn $ fromJust $ _plMID btplmnt)
                 30
                 (V2 0 h)
                 (V2 x h)
-                0.5
+                (defaultDoor & drTrigger .~ WdBlBtOn (fromJust $ _plMID btplmnt)
+                    & drUpdate . drLerpSpeed .~ 0.5)
             $ \dr1 dr2 ->
                 Just
                     . sps0
@@ -137,6 +138,41 @@ addButtonSlowDoor x h =
     lsx = 30
     lp@(V2 lx ly) = V2 100 (-20)
 
+makeDumbSwitch :: Int -> Button
+makeDumbSwitch i = defaultButton & btEvent .~ ButtonDumbSwitch i
+
+slowCrushRoom :: RandomGen g => State g Room
+slowCrushRoom = do
+    rm <- shuffleLinks =<< roomRectAutoLights 200 100
+    let rm' = removeLights rm
+            & rmPmnts .~ [spanLightI (V2 0 60) (V2 35 100)
+                , spanLightI (V2 200 60) (V2 165 100)
+                ]
+    return $ rm'
+        & rmLinks %~ setOutLinksByType (OnEdge East)
+        & rmLinks %~ setInLinksByType (OnEdge West)
+        & rmPmnts .:~
+         (ps0 (PutTrigger False) $ \i -> Just $
+            pContID (apos West 5) (PutButton $ makeDumbSwitch i) $ \_ -> Just $
+            pContID (apos East (-5)) (PutButton $ makeDumbSwitch i) $ \_ -> Just $
+        sps0 (PutDoor (dr & drTrigger .~ WdTrig i) defaultDoorWall) & plIDCont . mapped . mapped ?~
+        sps0 (PutDoor (dr1 & drTrigger .~ WdTrig i) defaultDoorWall)
+        )
+        
+  where
+    dr = defaultDoor
+        & drUpdate .~ DoorLerp 0.01
+        & drZeroPos .~ (V2 65 (-40), 0)
+        & drOnePos .~ (V2 65 50, 0)
+        & drFootPrint .~ IM.fromDistinctAscList (zip [0..] (loopPairs . reverse $ rectWH 35 50))
+    dr1 = dr
+        & drOnePos .~ (V2 135 (-40), 0)
+        & drZeroPos .~ (V2 135 50, 0)
+    apos edge x = (rprBool (t edge) & psSelect . mapped . mapped . _Just . _1 %~ (psRot +~ pi) . (psPos +~ V2 x 0))
+    t edge rp _ = case _rpType rp of
+        UnusedLink s -> OnEdge edge `S.member` s
+        _ -> False
+
 slowDoorRoom :: RandomGen g => State g Room
 slowDoorRoom = do
     x <- state $ randomR (400, 800)

src/Dodge/Room/Modify.hs

@@ -48,10 +48,10 @@ addLightsNGon rm = do
     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)
+        let ps = maybe (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 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))
@@ -61,7 +61,7 @@ addLightsNGon rm = do
         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))
+    rpToPS rp = PS (_rpPos rp) (_rpDir rp)
     iscolorlight rp =
         (ColoredLightRP `S.member` (rp ^. rpFlags))
             && islinkroompos rp

src/Dodge/Room/Pillar.hs

@@ -5,6 +5,7 @@ module Dodge.Room.Pillar (
     roomPillarsPassage,
 ) where
 
+import Linear
 import qualified Data.Set as S
 import Dodge.Cleat
 import Dodge.Data.GenWorld
@@ -60,7 +61,7 @@ roomPillarsSquare = do
                     [ mntLS
                         vShape
                         (rotateVAround (V2 150 150) a (V2 30 30))
-                        (onXY (rotateVAround (V2 150 150) a) $ V3 60 60 95)
+                        (_xy %~ rotateVAround (V2 150 150) a $ V3 60 60 95)
                     | a <- [0, pi / 2, pi, 3 * pi / 2]
                     ]
             , return
@@ -69,7 +70,7 @@ roomPillarsSquare = do
                     [ mntLS
                         vShape
                         (rotateVAround (V2 150 150) a (V2 150 0))
-                        (onXY (rotateVAround (V2 150 150) a) $ V3 150 20 95)
+                        (_xy %~ rotateVAround (V2 150 150) a $ V3 150 20 95)
                     | a <- [0, pi / 2, pi, 3 * pi / 2]
                     ]
             , addGirderLights . set rmPmnts []

src/Dodge/Room/Procedural.hs

@@ -37,7 +37,7 @@ import RandomHelp
 
 --import Control.Lens
 -- This will need a cleanup, but it might change a bit first
-{- A simple rectangular room with a light in the center.
+{- A simple rectangular room with no lights.
 Creates links and pathfinding graph.  -}
 roomRect :: Float -> Float -> Int -> Int -> Room
 roomRect x y xn yn =
@@ -310,7 +310,4 @@ centerVaultRoom w h d =
                     sPS (V2 0 (d -10)) 0 (putSlideDr (thedoor btid) thewall 1 (V2 21 0) (V2 0 0))
         ]
     thewall = defaultDoorWall
-    thedoor btid =
+    thedoor btid = defaultDoor & drTrigger .~ WdBlBtOn btid
-        defaultDoor
-            & drTrigger .~ WdBlBtOn btid
-            & drUpdate . drLerpSpeed .~ 2

src/Dodge/Room/SensorDoor.hs

@@ -24,8 +24,6 @@ import Geometry
 import LensHelp
 import RandomHelp
 
--- TODO fix case where the sensor created by sensInsideDoor blocks another door
--- for roomRectAutoLinks-- make the locked door a center door?
 sensorRoom :: SensorType -> Int -> State LayoutVars (Tree Room)
 sensorRoom senseType n = do
     rm <-
@@ -49,7 +47,7 @@ sensorRoom senseType n = do
         | isclose = rl & rlType . at BlockedLink ?~ ()
         | otherwise = rl
       where
-        p' = p +.+ rotateV d (V2 0 (negate 100))
+        p' = p + rotateV d (V2 0 (negate 100))
         isclose = dist (_rlPos rl) p' < 30
 
 nonCornerLinks :: RoomLink -> Bool

src/Dodge/Room/Tutorial.hs

@@ -8,7 +8,6 @@ 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
@@ -56,6 +55,8 @@ tutAnoTree = do
     foldMTRS
         [ tToBTree "TutStartRez" . return . cleatOnward <$> tutRezBox
         , corDoor
+        , tToBTree "slowCrush" . return . cleatOnward <$> slowCrushRoom
+        , corDoor
         , chasmSpitTerminal
 --a        , return $ tToBTree "cor" $ return $ cleatOnward corridor
 --a        , corDoor
@@ -238,8 +239,8 @@ sqPlatformChasm b a =
 
 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]]
-        convexPartition clfs
+--    ( earClip clfs
     , [clfs]
     )
   where
@@ -304,20 +305,21 @@ chasmSpitTerminal = do
         l3 = mntLightLnkShape shp $ resetPLUse $ rprBool $ \rp _ -> f rp East North 
         l4 = mntLightLnkShape shp $ resetPLUse $ rprBool $ \rp _ -> f rp East South
     ls <- takeOne [[l1,l2],[l3,l4]
-          ,[spanLightI (V2 120 0) (V2 120 300)]
+--          ,[spanLightI (V2 120 0) (V2 120 300)]
-         , [spanLightI (V2 0 128) (V2 300 128)]
+--         , [spanLightI (V2 0 128) (V2 300 128)]
-         , [spanLightI (V2 300 0) (V2 0 300), sps0 $ putShape $ thinHighBar 95 0 300]
+--         , [spanLightI (V2 300 0) (V2 0 300), sps0 $ putShape $ thinHighBar 95 0 300]
         ]
     gh <- takeOne [55,75,97]
     gird <- takeOne [girderZ gh 30 10,girder gh 30 10,girderV gh 30 10]
-    dec <- takeOne $ -- replicate 3 [] <> 
+    dec <- takeOne $  replicate 3 [] <> 
-            [--[]
+            [[sps0 $ putShape $ gird (V2 30 0) (V2 30 300)]
---            ,[sps0 $ putShape $ gird (V2 30 0) (V2 30 300)
+            ,[sps0 $ putShape $ gird (V2 270 0) (V2 270 300)]
---            ,sps0 $ putShape $ gird (V2 270 0) (V2 270 300)]
+            ,[sps0 $ putShape $ gird (V2 30 0) (V2 30 300),sps0 $ putShape $ gird (V2 270 0) (V2 270 300)]
---            ,[sps0 $ putShape $ gird (V2 0 20) (V2 300 20)]
+            ,[sps0 $ putShape $ gird (V2 0 20) (V2 300 20)]
-            [sps0 $ putShape $ gird (V2 0 200) (V2 300 200)]
+            ,[sps0 $ putShape $ gird (V2 0 200) (V2 300 200)]
+            ,[sps0 $ putShape $ gird (V2 0 280) (V2 300 280)]
+            ,[sps0 $ putShape $ gird (V2 0 20) (V2 300 20),sps0 $ putShape $ gird (V2 0 280) (V2 300 280)]
             ]
-    -- let y' = y & rmPmnts <>~ [l3, l4, l5]
     let y' = y & rmPmnts <>~ ls <> dec
     return $
         tToBTree "chasmTerm" $
@@ -328,8 +330,8 @@ chasmSpitTerminal = do
                 , return $ cleatOnward $ triggerDoorRoom i1
                 ]
   where
-    f rp a b = FromEdge a 2 `S.member` (fold $ rp ^? rpType . rplsType)
+    f rp a b = FromEdge a 2 `S.member` fold (rp ^? rpType . rplsType)
-        && OnEdge b `S.member` (fold $ rp ^? rpType . rplsType)
+        && OnEdge b `S.member` fold (rp ^? rpType . rplsType)
 
 polyChasm :: Int -> Float -> State LayoutVars Room
 polyChasm n x =
@@ -377,8 +379,8 @@ chasmSimpleMaze =
 
 tutLight :: State LayoutVars (MetaTree Room String)
 tutLight = do
-    x <- shuffleRoomPos =<< chasmSimpleMaze
+    x <- rmPos shuffle =<< chasmSimpleMaze
-    y <- shuffleRoomPos =<< chasmSimpleMaze
+    y <- rmPos shuffle =<< chasmSimpleMaze
     z <- chasmSimpleMaze
     return $
         tToBTree "TutLight" $

src/Dodge/SelectionSections.hs

@@ -41,21 +41,35 @@ ssScrollUsing ::
     Maybe Selection
 ssScrollUsing g = ssScrollMinOnFail g . fmap (ssItems %~ IM.filter _siIsSelectable)
 
+-- 
 ssScrollMinOnFail ::
     (Int -> Int -> IMSS a -> Maybe (Int, Int, SelectionItem a)) ->
     IMSS a ->
     Maybe Selection ->
     Maybe Selection
-ssScrollMinOnFail f sss msel = fmap (\(i, j, _) -> Sel i j (q i j)) $ l <|> ssLookupMin sss
+ssScrollMinOnFail f sss msel = fmap (\(i, j, _) -> Sel i j q) $ l <|> ssLookupMin sss
   where
-    q i j = fromMaybe mempty $ do
+    q = fold (msel ^? _Just . slSet)
-        Sel k _ xs <- msel ^? _Just
-        guard $ j `IS.member` xs && i == k
-        return xs
     l = do
         Sel i j _ <- msel
         f i j sss
 
+---- this version removes the selected set when scrolling outside it
+--ssScrollMinOnFail' ::
+--    (Int -> Int -> IMSS a -> Maybe (Int, Int, SelectionItem a)) ->
+--    IMSS a ->
+--    Maybe Selection ->
+--    Maybe Selection
+--ssScrollMinOnFail' f sss msel = fmap (\(i, j, _) -> Sel i j (q i j)) $ l <|> ssLookupMin sss
+--  where
+--    q i j = fromMaybe mempty $ do
+--        Sel k _ xs <- msel ^? _Just
+--        guard $ j `IS.member` xs && i == k
+--        return xs
+--    l = do
+--        Sel i j _ <- msel
+--        f i j sss
+
 ssSetCursor ::
     (IMSS a -> Maybe (Int, Int, SelectionItem a)) ->
     IMSS a ->

src/Dodge/TestString.hs

@@ -1,6 +1,7 @@
 {-# OPTIONS_GHC -Wno-unused-imports #-}
 module Dodge.TestString where
 
+import Dodge.WallCreatureCollisions
 import Data.List ((\\))
 import ShortShow
 import Geometry
@@ -33,8 +34,23 @@ import Data.Monoid
 import RandomHelp
 
 testStringInit :: Universe -> [String]
-testStringInit u = [evalState (takeOne ["a","b"]) (_randGen $ _uvWorld u)]
+testStringInit u = (fmap show $ u ^.. uvWorld . cWorld . lWorld . creatures . each . crWallTouch)
---    (fmap show $ u ^.. uvWorld . cWorld . lWorld . machines . each . mcType . _McDamSensor . sensAmount)
+    <> fromMaybe [] (do
+    w1 <- u ^? uvWorld . cWorld . lWorld . walls . ix 18
+    w2 <- u ^? uvWorld . cWorld . lWorld . walls . ix 61
+    let 
+        f = uncurry (-) . (^. wlLine)
+        g = argV . f
+        h = normalizeV . uncurry (-) . (^. wlLine)
+        a = angleVV (f w1) (f w2)
+    return [show $ wlWlCrush w1 w2, show a , show (f w1), show (f w2)
+        , show $ g w1
+        , show $ g w2
+        , show $ h w1
+        , show $ h w2
+        , show (norm (h w1 + h w2))
+        ]
+    )
 --    <> (fmap show $ u ^.. uvWorld . cWorld . lWorld . machines . each . mcMaterial)
 --testStringInit u = map show (u ^.. uvWorld . cWorld . lWorld . machines . traverse . mcDir)
 --testStringInit u =  map show

src/Dodge/Tree/Shift.hs

@@ -42,6 +42,7 @@ positionRoomsFromTree (Node (r, i) ts) =
   where
     r' = r & rmMID ?~ i
 
+-- implement a heuristic for "better" room links?
 posRms ::
     PosRooms ->
     RoomInt ->

src/Dodge/Update.hs

@@ -155,10 +155,32 @@ updateUniverseLast u =
             %~ M.union (fmap (const mp) (u ^. uvWorld . input . mouseButtons))
         & uvWorld . input . heldWorldPos
             %~ M.union (fmap (const mwp) (u ^. uvWorld . input . mouseButtons))
+        & uvIOEffects %~ doMouseWarping u
   where
     mp = u ^. uvWorld . input . mousePos
     mwp = screenToWorldPos (u ^. uvWorld . wCam) mp
 
+doMouseWarping :: p -> a -> a
+doMouseWarping _ = id
+
+--doMouseWarping :: Universe -> (Universe -> IO Universe) -> (Universe -> IO Universe)
+--doMouseWarping u f u'
+--    | Just x <- u ^? uvWorld . input . mouseContext . mcoRotateDist
+--        = SDL.warpMouse WarpCurrentFocus (P p) >> f (u' & uvWorld . input . mousePos .~ nmp)
+--    | otherwise = f u'
+--  where
+--    cfig = u' ^. uvConfig
+--    nmp = V2
+--            (fromIntegral x - 0.5 * windowXFloat cfig)
+--            (0.5 * windowYFloat cfig - fromIntegral y)
+--    p@(V2 x y) = (cwin + (msp & each %~ round)) & each %~ fromIntegral
+--    cwin :: V2 Int
+--    cwin = ((getWindowSize _gr_world_res (u' ^. uvConfig))) 
+--    mwp = mouseWorldPosW (u' ^. uvWorld)
+--    msp = u' ^. uvWorld . input . mousePos & _y %~ negate
+--    cc = u' ^. uvWorld . wCam . camCenter
+--    d = dist mwp cc
+
 {- For most menus the only way to change the world is using event handling.  -}
 updateUniverseMid :: Universe -> Universe
 updateUniverseMid u = case _uvScreenLayers u of
@@ -320,6 +342,7 @@ functionalUpdate =
 pushYouOutFromWalls :: World -> World
 pushYouOutFromWalls w = w & cWorld . lWorld . creatures . ix 0 %~ muzzleWallCheck w
 
+-- rotate creature as well? behaviour on ledges?
 muzzleWallCheck :: World -> Creature -> Creature
 muzzleWallCheck w cr = fromMaybe cr $ do
     invid <- cr ^? crManipulation . manObject . imRootSelectedItem . unNInt
@@ -329,14 +352,14 @@ muzzleWallCheck w cr = fromMaybe cr $ do
         cp = cr ^. crPos . _xy
 --        cop = cr ^. crOldPos . _xy
     r <- boundPointsRect (cp : ps)
-    let wls = uncurry wlsNearRect r w & filter (not . _wlTouchThrough)
+    let wls = uncurry wlsNearRect r w & IM.elems & filter (not . _wlTouchThrough)
         vs = mapMaybe (g cp wls) ps
     return $ if null vs 
         then cr
         else let v = minimumBy (compare `on` norm) vs
             in cr & crPos . _xy +~ normalize v
   where
-    f loc = map (muzzlePos loc cr)  (itemMuzzles $ loc)
+    f loc = map (muzzlePos loc cr)  (itemMuzzles loc)
     g cp wls p = case collidePoint cp p wls of
         (ep,Just _) -> Just (ep - p)
         _ -> Nothing
@@ -380,14 +403,17 @@ updateMouseContextGame :: Config -> Universe -> MouseContext -> MouseContext
 updateMouseContextGame cfig u = \case
     OverInvDrag i _ -> OverInvDrag i (inverseSelNumPos cfig invDP mpos disss)
     x@OverInvDragSelect{} -> x
-    _ -> fromMaybe aimcontext (isrotatedrag <|> overterm <|> overinv <|> overcomb)
+    MouseGameRotate x
+        | ButtonRight `M.member` (w ^. input . mouseButtons) -> MouseGameRotate x
+    --_ -> fromMaybe aimcontext (isrotatedrag <|> overterm <|> overinv <|> overcomb)
+    _ -> fromMaybe aimcontext (overterm <|> overinv <|> overcomb)
   where
     w = u ^. uvWorld
-    isrotatedrag = do
+--    isrotatedrag = do
-        t1 <- w ^. input . mouseButtons . at ButtonLeft
+--        t1 <- w ^. input . mouseButtons . at ButtonLeft
-        t2 <- w ^. input . mouseButtons . at ButtonRight
+--        t2 <- w ^. input . mouseButtons . at ButtonRight
-        guard $ t1 > t2
+--        guard $ t1 > t2
-        return MouseGameRotate
+--        return $ MouseGameRotate (dist (mouseWorldPosW w) (w ^. wCam . camCenter))
     aimcontext
         | ButtonRight `M.member` (w ^. input . mouseButtons) = MouseAiming
         | Display_debug `S.member` (cfig ^. debug_booleans) = getDebugMouseOver u
@@ -515,7 +541,7 @@ updatePulseBall pb w
     thedam = Lasering 100 ep (pb ^. pzbVel)
     sp = pb ^. pzbPos
     ep = sp + pb ^. pzbVel
-    thit = thingHit sp ep w
+    thit = listToMaybe $ thingsHitZ 20 sp ep w
 
 pbFlicker :: PulseBall -> World -> World
 pbFlicker pt =
@@ -676,7 +702,7 @@ updatePulseLaser pz = case pz ^. pzTimer of
   where
     f w =
         dodam thHit w
-            & cWorld . lWorld . flares <>~ drawLaser cyan (sp : ps)
+            & cWorld . lWorld . flares <>~ drawPulseLaser (sp : ps)
       where
         (thHit, ps) = reflectPulseLaserAlong phasev sp xp w
     dodam thit = case thit of
@@ -695,7 +721,7 @@ updatePulseLaser pz = case pz ^. pzTimer of
     sp = _pzPos pz
     dir = _pzDir pz
     xp = sp +.+ 800 *.* unitVectorAtAngle dir
-    g w = w & cWorld . lWorld . flares <>~ drawLaser cyan (sp : ps)
+    g w = w & cWorld . lWorld . flares <>~ drawPulseLaser (sp : ps)
       where
         (_, ps) = reflectPulseLaserAlong phasev sp xp w
 

src/Dodge/Update/Camera.hs

@@ -26,6 +26,7 @@ import Geometry
 import LensHelp
 import SDL (MouseButton (..))
 import qualified SDL
+import qualified Data.IntMap.Strict as IM
 
 {- Update the screen camera rotation and position, including any in rold scope/remote camera modifiers;
 update where your avatar's view is from.  -}
@@ -203,12 +204,14 @@ viewDistanceFromItems _ = 1
 
 rotateCamera :: Config -> World -> World
 rotateCamera cfig w
-    | MouseGameRotate <- w ^. input . mouseContext
+    | MouseGameRotate {} <- w ^. input . mouseContext
       , Just rotation <-
             angleBetween (w ^. input . mousePos)
                 <$> (w ^. input . heldPos . at SDL.ButtonRight) =
         w & wCam . camRot -~ rotation
+          & input . inputMemory .~ WasMouseGameRotating
     | _gameplay_rotate_to_wall cfig
+        , WasNotMouseGameRotating <- w ^. input . inputMemory
       , isNothing $ w ^? input . mouseButtons . ix SDL.ButtonRight =
         rotateToOverlappingWall w
     | otherwise = w
@@ -218,23 +221,15 @@ rotateToOverlappingWall w =
     maybe
         id
         (doWallRotate . snd)
-        (overlapCircWallsClosest p r (filter _wlRotateTo $ wlsNearCirc p r w))
+        (overlapCircWallsClosest p r (filter _wlRotateTo . IM.elems $ wlsNearCirc p r w))
         w
   where
-    r = (crRad (cr ^. crType) + 10)
+    r = crRad (cr ^. crType) + 10
     cr = you w
     p = you w ^. crPos . _xy
 
 doWallRotate :: Wall -> World -> World
 doWallRotate = rotateTo8 . argV . uncurry (-) . _wlLine
---doWallRotate wl w = rotateTo8 
---    | b - b' > 0.01 = w & wCam . camRot +~ 0.01
---    | b - b' < negate 0.01 = w & wCam . camRot -~ 0.01
---    | otherwise = w
---  where
---    a = argV (uncurry (-.-) $ _wlLine wl) - w ^. wCam . camRot
---    b = a * (4 / pi) -- for 8 way cardinal orientation wrt wall
---    b' = fromIntegral (round b :: Int)
 
 clipZoom ::
     -- | Furthest viewable distance
@@ -251,7 +246,7 @@ farWallDistDirection :: Point2 -> World -> Maybe (Float, Float, Float, Float)
 farWallDistDirection p w = boundPoints $ map f $ getViewpoints p (_cWorld w)
   where
     f q = (rotateV (negate (w ^. wCam . camRot)) . (-.- p)) (foldl' findPoint q (wls q))
-    wls q = filter wlIsOpaque $ wlsNearSeg p q w
+    wls q = filter wlIsOpaque . IM.elems $ wlsNearSeg p q w
     findPoint q = fromMaybe q . uncurry (intersectSegSeg p q) . _wlLine
 
 findBoundDists :: Config -> World -> (Float, Float, Float, Float)

src/Dodge/Update/Input/InGame.hs

@@ -5,6 +5,7 @@ module Dodge.Update.Input.InGame (
     updateMouseInGame,
 ) where
 
+import Dodge.Base.Coordinate
 import Dodge.Button.Event
 import Control.Applicative
 import Control.Monad
@@ -98,7 +99,7 @@ updateMouseHeldInGame :: Config -> World -> World
 updateMouseHeldInGame cfig w = case w ^. input . mouseContext of
     OverInvDragSelect{}
         | ButtonRight `M.member` (w ^. input . mouseButtons) ->
-            w & input . mouseContext .~ MouseGameRotate
+            w & input . mouseContext .~ MouseGameRotate (dist (mouseWorldPosW w) (w ^. wCam . camCenter))
     OverInvDragSelect (Just sstart) _ ->
         let sss = w ^. hud . diSections
             msel = inverseSelNumPos cfig invDP (w ^. input . mousePos) sss
@@ -289,23 +290,6 @@ startDrag (a, b) w = setcontext $ case w ^? hud . diSelection . _Just of
   where
     setcontext = input . mouseContext .~ OverInvDrag a (Just (a, b))
 
-concurrentIS :: IS.IntSet -> Bool
-concurrentIS = go . IS.minView
-  where
-    go x = fromMaybe True $ do
-        (i, is) <- x
-        (j, js) <- IS.minView is
-        return $ i + 1 == j && go (Just (j, js))
-
-collectInvItems :: Int -> IS.IntSet -> World -> World
-collectInvItems secid is w = fromMaybe w $ do
-    guard $ secid == 0
-    (j, js) <- IS.minView is
-    return $ h j js w
-  where
-    h j js w' = fromMaybe w' $ do
-        (k, ks) <- IS.minView js
-        return . h (j + 1) ks $ swapInvItems (\_ _ -> Just (j + 1)) k w'
 
 shiftInvItems ::
     Config ->
@@ -346,20 +330,6 @@ setSelWhileDragging w = fromMaybe w $ do
     guard $ i == k && j `IS.member` xs
     return $ w & hud . diSelection . _Just . slInt .~ j
 
-shiftInvItemsUp :: Int -> IS.IntSet -> World -> World
-shiftInvItemsUp j is w = IS.foldl' f w is
-  where
-    f w' i' = swapItemWith g (j, i') w'
-    g i' m = fst <$> IM.lookupLT i' m
-
-shiftInvItemsDown :: Int -> IS.IntSet -> World -> World
-shiftInvItemsDown j is w = fromMaybe w $ do
-    let i = IS.findMax is
-    guard . isJust $ w ^? hud . diSections . ix j . ssItems . ix i
-    return $ IS.foldr f w is
-  where
-    f i' = swapItemWith g (j, i')
-    g i' m = fst <$> IM.lookupGT i' m
 
 updateFunctionKeys :: Universe -> Universe
 updateFunctionKeys u =
@@ -427,7 +397,7 @@ updateKeysTextInputTerminal tmid u =
 
 updateKeyInGame :: Universe -> Scancode -> Int -> Universe
 updateKeyInGame uv sc = \case
-    0 -> updateInitialPressInGame uv sc
+    0 -> updateInitialPressInGame uv sc & uvWorld . input . inputMemory .~ WasNotMouseGameRotating
     x | x >= 30 -> updateLongPressInGame uv sc
     _ -> uv
 

src/Dodge/Update/Scroll.hs

@@ -29,13 +29,15 @@ updateWheelEvent yi w = case w ^. hud . subInventory of
 -- yi should be nonzero
 updateBaseWheelEvent :: Int -> World -> World
 updateBaseWheelEvent yi w
-    --    | Just True <- w ^? cWorld . lWorld . creatures . ix 0 . crInvLock = w
     | Just True <- w ^? cWorld . lWorld . lInvLock = w
     | bdown ButtonRight = case _rbState w of
         EquipOptions{} -> w & rbState . opSel %~ scrollRBOption yi rbscrollmax
         NoRightButtonState -> fromMaybe w (selectedItemScroll yi w)
     | bdown ButtonLeft = w & wCam . camZoom +~ fromIntegral yi
-    | ScancodeCapsLock `M.member` _pressedKeys (_input w) = changeSwapSel yi w
+    | ScancodeCapsLock `M.member` _pressedKeys (_input w) 
+        , ScancodeLShift `M.member` (w ^. input . pressedKeys) = changeSwapSel yi w
+    | ScancodeCapsLock `M.member` _pressedKeys (_input w) = changeSwapSelSet yi w
+    | ScancodeLShift `M.member` (w ^. input . pressedKeys) = multiSelScroll yi w
     | otherwise = scrollAugInvSel yi w
   where
     bdown b = w & has (input . mouseButtons . ix b)

src/Dodge/WallCreatureCollisions.hs

@@ -1,23 +1,20 @@
 -- | Deals with moving creature wall collisions.
-module Dodge.WallCreatureCollisions (
+module Dodge.WallCreatureCollisions (colCrsWalls,
-    colCrsWalls,
+    wlWlCrush
-    colCrWall,
+    ) where
-    pushCreatureOutFromWalls,
-    crOnWall,
-) where
 
-import Linear
+import qualified Data.IntMap.Strict as IM
-import Dodge.Creature.Radius
 import Control.Lens
-import Data.Maybe
+import Data.Foldable
-import Data.Monoid
+import qualified Data.IntSet as IS
 import Dodge.Base
+import Dodge.Creature.Radius
 import Dodge.Data.Universe
 import Dodge.Zoning.Wall
 import Geometry
+import Linear
 
 colCrsWalls :: Universe -> Universe
---colCrsWalls uv = uv
 colCrsWalls uv = uv & uvWorld . cWorld . lWorld . creatures %~ fmap (noclipCheck (_uvConfig uv) (_uvWorld uv))
 
 noclipCheck :: Config -> World -> Creature -> Creature
@@ -25,77 +22,55 @@ noclipCheck cfig w c
     | debugOn Noclip cfig && _crID c == 0 = c -- for noclip
     | otherwise = colCrWall w c
 
--- no noclip check, so no need for a configuration file
 colCrWall :: World -> Creature -> Creature
-colCrWall w c
+colCrWall w c = cornpush . wallpush $ pushthrough c
-    | p1 == p2 = pushOrCrush ls c
-    --    | _crPos c' == _crPos c'' = c'
-    --    | otherwise = c & crPos .~ _crOldPos c
-    | otherwise = c'
   where
-    --    c'' = c' & crPos %~ pushOutFromWalls rad ls
+    cornpush = crPos . _xy %~ pushOutFromCorners r ls'
-    --c'  = c & crPos %~ pushOutFromWalls' rad (reverse ls)
+    wallpush = pushCr wls
-    c' =
+    pushthrough = crPos . _xy %~ fst . flip (collidePoint p1) wls -- check push throughs
-        c & crPos . _xy
-            %~ pushOutFromCorners r ls'
-                . pushOutFromWalls r ls'
-                . fst
-                . flip (collidePoint p1) wls -- check push throughs
-                --        . flip (collidePointWalls' p1) wls  -- check push throughs
     r = crRad (c ^. crType) + wallBuffer
     p1 = c ^. crOldPos . _xy
     p2 = c ^. crPos . _xy
-    ls = _wlLine <$> wls
+    ls = _wlLine <$> IM.elems wls
     ls' = filter (uncurry $ isLHS p1) ls
-    wls = filter notff $ wlsNearRect (p2 +.+ V2 r r) (p2 -.- V2 r r) w
+    wls = IM.filter notff $ wlsNearCirc p2 (2*r) w
     notff x = x ^. wlMaterial /= ForceField
 
+-- might want to check angled crushing
+pushCr :: IM.IntMap Wall -> Creature -> Creature
+pushCr wls cr
+    | (dist ep sp > r && dist ep ap > r)
+        || wlsCrush twls
+            =
+        ecr
+            & crDamage <>~ [Crushing 1000 0]
+            & crPos . _xy .~ ap
+    | otherwise = ecr
+  where
+--    stwls = IM.filter (\wl -> uncurry circOnSegNoEndpoints (wl ^. wlLine) sp r) wls
+    twls = IM.elems $ IM.restrictKeys wls (ecr ^. crWallTouch) -- `IM.union` stwls
+    ep = ecr ^. crPos . _xy
+    ap = cr ^. crOldPos . _xy
+    sp = cr ^. crPos . _xy
+    ecr = foldl' f (cr & crWallTouch .~ mempty) wls
+    r = crRad (cr ^. crType)
+    f acr wl = case pushOutFromWall r (acr ^. crPos . _xy) (wl ^. wlLine) of
+        Just p -> acr & crPos . _xy .~ p & crWallTouch %~ IS.insert (wl ^. wlID)
+        Nothing -> acr
+
+wlsCrush :: [Wall] -> Bool
+wlsCrush [] = False
+wlsCrush (x:xs) = any (wlWlCrush x) xs || wlsCrush xs
+
+wlWlCrush :: Wall -> Wall -> Bool
+wlWlCrush w1 w2 = norm (f w1 + f w2) < 0.2
+  where
+    f = normalizeV . uncurry (-) . (^. wlLine)
+
 -- the amount to push creatures out from walls, extra to their radius
 wallBuffer :: Float
 wallBuffer = 0
 
-pushCreatureOutFromWalls :: [(Point2, Point2)] -> Creature -> Creature
-pushCreatureOutFromWalls ls cr = cr & crPos . _xy 
-    %~ pushOutFromWalls (crRad (cr ^. crType)) ls
-
--- the following tests whether or not a point is on a wall, and if so pushes it
--- out from the wall
--- this is then repeated if the point ends up on a new wall
-pushOutFromWalls :: Float -> [(Point2, Point2)] -> Point2 -> Point2
-pushOutFromWalls rad wls p1 = case (getFirst . foldMap (First . pushOutFromWall rad p1)) wls of
-    Nothing -> p1
-    Just p2 -> pushOutFromWalls rad (tail wls) p2
-
--- possible improvement: choose between the closer of p2 and "p3" to p1
-
---pushOutFromWalls' :: Float -> [(Point2,Point2)] -> Point2 -> Point2
---pushOutFromWalls' rad wls p1 = case (getFirst . foldMap (First . pushOutFromWall' rad p1)) wls of
---    Nothing -> p1
---    Just p2 -> fromMaybe p2 $ (getLast . foldMap (Last . pushOutFromWall' rad p2)) wls
---    -- possible improvement: choose between the closer of p2 and "p3" to p1
-
-pushOrCrush :: [(Point2, Point2)] -> Creature -> Creature
-pushOrCrush wls cr = case mapMaybe (pushOutFromWall (crRad (cr ^. crType)) cpos) wls of
-    [] -> cr
-    (p : _) -> cr & crPos . _xy .~ p
-  where
-    --    (_:p:_)   -> cr
-    --        & crPos .~ p
-    --        & crState . crDamage %~ ( Blunt 50 cpos cpos cpos : )
-
-    cpos = cr ^. crPos . _xy
-
--- note the inclusion of endpoints in circOnSeg
-crOnWall :: Creature -> World -> Bool
-crOnWall cr =
-    any (uncurry (circOnSeg p r) . _wlLine)
-        . filter notff
-        . wlsNearCirc p r
-  where
-    notff x = x ^. wlMaterial /= ForceField
-    p = cr ^. crPos . _xy
-    r = crRad (cr ^. crType)
-
 -- assumes that the wall is orientated
 -- assumes wall points are different
 pushOutFromWall :: Float -> Point2 -> (Point2, Point2) -> Maybe Point2
@@ -103,17 +78,16 @@ pushOutFromWall rad cp2 (wp1, wp2)
     | isOnWall = Just newP
     | otherwise = Nothing
   where
-    n = errorNormalizeV 61 $ vNormal (wp1 -.- wp2)
+    n = errorNormalizeV 61 $ vNormal (wp1 - wp2)
-    wp1' = wp1 +.+ rad *.* n
+    wp1' = wp1 + rad *^ n
-    wp2' = wp2 +.+ rad *.* n
+    wp2' = wp2 + rad *^ n
     newP = errorClosestPointOnLine 5 wp1' wp2' cp2
     isOnWall = circOnSegNoEndpoints wp1 wp2 cp2 rad
 
 pushOutFromCorners :: Float -> [(Point2, Point2)] -> Point2 -> Point2
---pushOutFromCorners r ls p = foldr (squashIntersectCirclePoint r . fst) p ls
 pushOutFromCorners r = flip $ foldr (squashIntersectCirclePoint r . fst)
 
 squashIntersectCirclePoint :: Float -> Point2 -> Point2 -> Point2
 squashIntersectCirclePoint rad p cCen
     | dist cCen p > rad = cCen
-    | otherwise = p +.+ (rad *.* squashNormalizeV (cCen -.- p))
+    | otherwise = p + (rad *^ squashNormalizeV (cCen - p))

src/Dodge/WorldEffect.hs

@@ -36,17 +36,15 @@ doWdWd = \case
     NoWorldEffect -> id
     SetTrigger bool tid -> cWorld . lWorld . triggers . ix tid .~ bool
     SetLSCol col lsid -> cWorld . lWorld . lightSources . ix lsid . lsParam . lsCol .~ col
+    SetTriggerAndSetLSCol bool tid col lsid -> (cWorld . lWorld . lightSources . ix lsid . lsParam . lsCol .~ col)
+             . (cWorld . lWorld . triggers . ix tid .~ bool)
     AccessTerminal mtmid -> accessTerminal mtmid
-    WorldEffects wes -> \w -> foldr doWdWd w wes
     UnlockInv -> unlockInv
     MakeStartCloudAt p -> makeCloudAt CryoReleaseCloud 400 p
     TorqueCr x cid -> torqueCr x cid
     SoundStart so p sid mi -> soundStart so p sid mi
     WdWdNegateTrig trid -> cWorld . lWorld . triggers . ix trid %~ not
     WdWdSetSoundFilter x -> wSoundFilter .~ x
-    --    WdWdFromItCrixWdWd it crid f -> \w -> fromMaybe w $ do
-    --        cr <- w ^? cWorld . lWorld . creatures . ix crid
-    --        return $ doItCrWdWd f it cr w
     MakeTempLight _ 0 -> id
     MakeTempLight x t ->
         (cWorld . lWorld . lights .:~ x)

src/Dodge/WorldEvent/ThingsHit.hs

@@ -14,6 +14,7 @@ module Dodge.WorldEvent.ThingsHit (
     wlHitPos,
     crHit,
     crWlPbHit,
+    crWlPbHitZ,
     wlsHitUnsorted,
     isWalkable,
 ) where
@@ -66,6 +67,20 @@ crWlPbHit sp ep w =
     toobj (Left cr) = OCreature cr
     toobj (Right wl) = OWall wl
 
+crWlPbHitZ :: Float -> Point2 -> Point2 -> World -> [(Point2, Object)]
+crWlPbHitZ z sp ep w =
+    List.mergeOn
+        (dist sp . fst)
+        (map (fmap toobj) (thingsHitZ z sp ep w))
+        pballs
+  where
+    -- slightly arbitrary
+    pballs 
+        | z > 15 && z < 25 = map (fmap OPulseBall) (pbsHit sp ep w)
+        | otherwise = mempty
+    toobj (Left cr) = OCreature cr
+    toobj (Right wl) = OWall wl
+
 crsHit :: Point2 -> Point2 -> World -> [(Point2, Creature)]
 crsHit sp ep w
     | sp == ep = mempty
@@ -139,19 +154,19 @@ thingsHitExceptCr (Just cid) sp ep = filter t . thingsHit sp ep
     t = (Just cid /=) . (^? _2 . _Left . crID)
 
 wlsHit :: Point2 -> Point2 -> World -> [(Point2, Wall)]
-wlsHit sp ep = sortOn (dist sp . fst) . wlsHitUnsorted sp ep
+wlsHit sp ep = sortOn (dist sp . fst) . IM.elems . wlsHitUnsorted sp ep
 
 ---- pushes out any hit point by one
 wlHitPos :: Point2 -> Point2 -> World -> Point2
 wlHitPos sp ep = maybe ep ((+ normalize (ep - sp)) . fst) . safeHead . wlsHit sp ep
 
-wlsHitUnsorted :: Point2 -> Point2 -> World -> [(Point2, Wall)]
+wlsHitUnsorted :: Point2 -> Point2 -> World -> IM.IntMap (Point2, Wall)
 wlsHitUnsorted sp ep
     | sp == ep = const mempty
     | otherwise = overlapSegWalls sp ep . wlsNearSeg sp ep
 
-wlsHitRadial :: Point2 -> Float -> World -> [(Point2, Wall)]
+wlsHitRadial :: Point2 -> Float -> World -> IM.IntMap (Point2, Wall)
-wlsHitRadial p r = mapMaybe f . wlsNearCirc p r
+wlsHitRadial p r = IM.mapMaybe f . wlsNearCirc p r
   where
     --f wl = uncurry (intersectSegSeg p (p - r *.* v)) (_wlLine wl) <&> (,wl)
     f wl = mhp <&> (,wl)

src/Dodge/WorldLoad.hs

@@ -30,7 +30,7 @@ postWorldLoad rdata cw = do
     glNamedBufferStorage newfloorbo (fromIntegral $ 8 * nfloorvxs * floatSize) floorptr 0
     nchasmvxs <- foldM (pokeChasm chptr) 0 (cw ^. uvWorld . cWorld . chasms)
     glBindBufferBase GL_SHADER_STORAGE_BUFFER 7 newchbo
-    glNamedBufferStorage newchbo (fromIntegral $ 2 * (max 1 nchasmvxs) * floatSize) chptr 0
+    glNamedBufferStorage newchbo (fromIntegral $ 2 * max 1 nchasmvxs * floatSize) chptr 0
     -- note the max 1, prevents trying to create empty buffer storage
     checkGLError "during postWorldLoad"
     return $

src/Dodge/Zoning/Wall.hs

@@ -11,7 +11,6 @@ module Dodge.Zoning.Wall
 
 import Control.Lens
 import qualified Data.IntSet as IS
-import Data.Maybe
 import Dodge.Data.World
 import Dodge.Zoning.Base
 import FoldableHelp
@@ -32,21 +31,21 @@ wlIXsNearRect = nearRect wlZoneSize _wlZoning
 wlIXsNearCirc :: Point2 -> Float -> World -> IS.IntSet
 wlIXsNearCirc p r = wlIXsNearRect (p +.+ V2 r r) (p -.- V2 r r)
 
-wlsFromIXs :: World -> IS.IntSet -> [Wall]
+wlsFromIXs :: World -> IS.IntSet -> IM.IntMap Wall
 {-# INLINE wlsFromIXs #-}
-wlsFromIXs w = mapMaybe (\wlid -> w ^? cWorld . lWorld . walls . ix wlid) . IS.toList
+wlsFromIXs w = IM.restrictKeys (w ^. cWorld . lWorld . walls)
 
-wlsNearPoint :: Point2 -> World -> [Wall]
+wlsNearPoint :: Point2 -> World -> IM.IntMap Wall
 wlsNearPoint p w = wlsFromIXs w $ wlIXsNearPoint p w
 
-wlsNearSeg :: Point2 -> Point2 -> World -> [Wall]
+wlsNearSeg :: Point2 -> Point2 -> World -> IM.IntMap Wall
 {-# INLINE wlsNearSeg #-}
 wlsNearSeg sp ep w = wlsFromIXs w $ wlIXsNearSeg sp ep w
 
-wlsNearRect :: Point2 -> Point2 -> World -> [Wall]
+wlsNearRect :: Point2 -> Point2 -> World -> IM.IntMap Wall
 wlsNearRect sp ep w = wlsFromIXs w $ wlIXsNearRect sp ep w
 
-wlsNearCirc :: Point2 -> Float -> World -> [Wall]
+wlsNearCirc :: Point2 -> Float -> World -> IM.IntMap Wall
 wlsNearCirc p r w = wlsFromIXs w $ wlIXsNearCirc p r w
 
 wlZoneSize :: Float

src/Geometry/Polygon.hs

@@ -151,13 +151,20 @@ convexHull :: [Point2] -> [Point2]
 convexHull (x : y : z : xs) = grahamScan $ orderAroundFirst $ sortOn (\(V2 a b) -> (b, a)) (x : y : z : xs)
 convexHull _ = error "Tried to create the convex hull of two or fewer points"
 
--- assumes the points go "anticlockwise" around a non-self intersecting shape
+---- assumes the points go "anticlockwise" around a non-self intersecting shape
-convexPartition :: [Point2] -> [[Point2]]
+--convexPartition :: [Point2] -> [[Point2]]
-convexPartition (x:y:z:[]) = [[x,y,z]]
+--convexPartition (x:y:z:[]) = [[x,y,z]]
-convexPartition (x:y:z:xs)
+--convexPartition (x:y:z:xs)
-    | isLHS x y z = [x,y,z] : convexPartition (x:z:xs)
+--    | isLHS x y z = [x,y,z] : convexPartition (x:z:xs)
-    | otherwise = convexPartition (y:z:xs <> [x])
+--    | otherwise = convexPartition (y:z:xs <> [x])
-convexPartition _ = error "unexpected shape for convexPartition"
+--convexPartition _ = error "unexpected shape for convexPartition"
+
+triangulateEarClip :: [Point2] -> [[Point2]]
+triangulateEarClip [x,y,z] = [[x,y,z]]
+triangulateEarClip (x:y:z:xs)
+    | isLHS x y z && not (any (`pointInPoly` [x,y,z]) xs) = [x,y,z] : triangulateEarClip (x:z:xs)
+    | otherwise = triangulateEarClip (y:z:xs ++ [x])
+triangulateEarClip _ = error "triangulateEarClip: non-simple polygon input?"
 
 {- | Creates the convex hull of a set of points.
  assumes no repetition of points: try nubbing!

src/Geometry/Vector3D.hs

@@ -45,11 +45,11 @@ crossProd (V3 x y z) (V3 a b c) = V3
     ( z * a - x * c)
     ( x * b - y * a)
 
-rotate3 :: Float -> Point3 -> Point3
+--rotate3 :: Float -> Point3 -> Point3
-{-# INLINE rotate3 #-}
+--{-# INLINE rotate3 #-}
-rotate3 a (V3 x y z) = V3 x' y' z
+--rotate3 a (V3 x y z) = V3 x' y' z
-  where 
+--  where 
-    (V2 x' y') = rotateV a (V2 x y)
+--    (V2 x' y') = rotateV a (V2 x y)
 
 rotate3z :: Float -> Point3 -> Point3
 {-# INLINE rotate3z #-}
@@ -124,10 +124,10 @@ angleVV3 a b
     | a == b = 0
     | otherwise = acos $ dotV3 a b / (magV3 a * magV3 b)
 
-projV3 :: Point3 -> Point3 -> Point3
+--projV3 :: Point3 -> Point3 -> Point3
-projV3 = undefined
+--projV3 = undefined
 
-onXY :: (Point2 -> Point2) -> Point3 -> Point3
+--onXY :: (Point2 -> Point2) -> Point3 -> Point3
-onXY f (V3 x y z) = V3 x' y' z
+--onXY f (V3 x y z) = V3 x' y' z
-  where
+--  where
-    V2 x' y' = f (V2 x y)
+--    V2 x' y' = f (V2 x y)

src/Picture/Base.hs

@@ -115,7 +115,7 @@ translate3 = fmap . overPos . (+.+.+)
 
 tranRot :: V2 Float -> Float -> Picture -> Picture
 {-# INLINE tranRot #-}
-tranRot (V2 x y) r = fmap $ overPos (translateH x y . rotate3 r)
+tranRot (V2 x y) r = fmap $ overPos (translateH x y . rotate3z r)
 
 setDepth :: Float -> Picture -> Picture
 {-# INLINE setDepth #-}
@@ -144,7 +144,7 @@ scale x = fmap . overPos . scale3 x
 
 rotate :: Float -> Picture -> Picture
 {-# INLINE rotate #-}
-rotate = fmap . overPos . rotate3
+rotate = fmap . overPos . rotate3z
 
 makeArc :: Float -> Point2 -> [Point2]
 {-# INLINE makeArc #-}

src/Polyhedra.hs

@@ -26,7 +26,7 @@ translateXY x y = pyFaces %~ map (map $ first tran)
     tran (V3 a b c) = V3 (a+x) (b+y) c
 
 rotateXY :: Float -> Polyhedra -> Polyhedra
-rotateXY a = over pyFaces $ map $ map $ first $ rotate3 a
+rotateXY = over pyFaces . map . map . first . rotate3z
 
 constructEdges :: [[Point3]] -> [(Point3,Point3,Point3,Point3)]
 constructEdges (face:faces) = mapMaybe (findReverseEdge otherEdges) (faceEdges face) 

src/RandomHelp.hs

@@ -28,7 +28,7 @@ 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
+        let (ys, z : zs) = splitAt i xs
         return $ Just (z, ys <> zs)
 
 takeOneFiltered :: (RandomGen g) => (a -> Bool) -> [a] -> State g (Maybe a)

src/Shape.hs

@@ -253,7 +253,7 @@ translateSHz !z = translateSH (V3 0 0 z)
 
 rotateSH :: Float -> Shape -> Shape
 {-# INLINE rotateSH #-}
-rotateSH = overPosSH . rotate3
+rotateSH = overPosSH . rotate3z
 
 overPosSH :: (Point3 -> Point3) -> Shape -> Shape
 {-# INLINEABLE overPosSH #-}