Add various capabilities for generating graphs, fixes to lasgun

package.yaml

@@ -25,6 +25,7 @@ dependencies:
 - unordered-containers
 - bitwise-enum
 - graphviz
+- template-haskell
   #- heap
 - sdl2
 - sdl2-mixer

src/Dodge/Beam.hs

@@ -4,6 +4,7 @@ import Dodge.Particle.Flame
 import Dodge.Particle.TeslaArc
 import Dodge.Item.Location
 import Dodge.WorldEvent.Damage
+--import Dodge.WorldEvent.ThingsHit
 import Dodge.WorldEvent.HelperParticle
 import Dodge.Item.Weapon.LaserPath
 import Geometry
@@ -50,12 +51,13 @@ teslaBeamCombine (p,(a,b,bm),(x,y,_)) w
 
 lasRayAt :: Color -> Int -> Float -> Point2 -> Float -> Particle
 lasRayAt col dam phasev pos dir = LaserParticle
-    { _ptDraw = const blank
+    { _ptDraw = drawLaser
     , _ptUpdate = mvLaser phasev pos dir
     , _ptRange = 800
     , _ptDamage = dam
     , _ptPhaseV = phasev
     , _ptColor = col
+    , _ptPoints = []
     }
 mvLaser :: Float    -- ^ Phase velocity, controls deflection through windows
     -> Point2 
@@ -63,19 +65,24 @@ mvLaser :: Float    -- ^ Phase velocity, controls deflection through windows
     -> World 
     -> Particle 
     -> (World, Maybe Particle)
-mvLaser phasev pos dir w pt
+mvLaser phasev sp dir w pt
-    = ( damThingHitWith (\p1 p2 p3 -> Damage LASERING dam p1 p2 p3 NoDamageEffect) pos xp thHit w
+    = ( damThingHitWith (\p1 p2 p3 -> Damage LASERING dam p1 p2 p3 NoDamageEffect) sp xp thHit w
-      , Just pt {_ptDraw = const pic ,_ptUpdate = ptSimpleTime 0 }
+      , Just pt {_ptPoints = sp:ps ,_ptUpdate = ptSimpleTime 0 }
       )
   where
     dam = _ptDamage pt
-    xp = pos +.+ 800 *.* unitVectorAtAngle dir
+    xp = sp +.+ 800 *.* unitVectorAtAngle dir
-    (thHit, ps) = reflectLaserAlong phasev [] pos xp w
+--    thHit' = thingHit sp xp w
+    (thHit, ps) = reflectLaserAlong phasev sp xp w
+
+drawLaser :: Particle -> Picture
+drawLaser pt = setLayer BloomNoZWrite $ pictures
+    [ setDepth 19   . color (brightX 0 0.5 col) $ thickLine 20 ps
+    , setDepth 19.5 . color (brightX 10 1 col)  $ thickLine 3  ps
+    ]
+  where
     col = _ptColor pt
-    pic = setLayer BloomNoZWrite $ pictures
+    ps = _ptPoints pt
-        [ setDepth 19   . color (brightX 0 0.5 col) $ thickLine 20 (pos:ps)
-        , setDepth 19.5 . color (brightX 10 1 col)  $ thickLine 3  (pos:ps)
-        ]
 
 shootTeslaArc' :: ItemParams -> Point2 -> Float -> World -> (World,ItemParams)
 shootTeslaArc' ip pos dir w = 

src/Dodge/Combine/Combinations.hs

@@ -16,41 +16,38 @@ import LensHelp
 
 itemCombinations :: [([(IcAmount,ItemBaseType)],Item)]
 itemCombinations =
-    [ po [CRAFT PIPE, CRAFT HARDWARE]             (bangStick 1)
+    [ po [CRAFT PIPE, CRAFT HARDWARE]      (bangStick 1)
     , po [BANGSTICK 1, CRAFT TIN]         pistol
-    , po [PISTOL, CRAFT SPRING, cr HARDWARE] autoPistol
+    , po [PISTOL, CRAFT SPRING] autoPistol
-    , po [AUTOPISTOL, cr PLANK, cr HARDWARE] smg
+    , po [AUTOPISTOL, cr PLANK] smg
-    , po [AUTOPISTOL, cr HARDWARE] machinePistol
+    , po [AUTOPISTOL, cr SPRING] machinePistol
     , po [BANGSTICK 1,cr CAN] revolver
-    , po [REVOLVER, cr SPRING, cr HARDWARE] $ revolverX 1
+    , po [REVOLVER, cr SPRING] $ revolverX 1
 
-    , po [cr TUBE,cr HARDWARE] bangCone
+    , po [cr CAN,cr HARDWARE] bangCone
     , po [BANGCONE,cr PLANK] blunderbuss
-    , po [BLUNDERBUSS,cr TUBE] bigBlunderbuss
+    , po [BLUNDERBUSS,cr DRUM] (grapeCannon 1)
-    , po [BIGBLUNDERBUSS,cr TUBE] biggerBlunderbuss
-    , po [BIGGERBLUNDERBUSS,cr TUBE] biggestBlunderbuss
 --    , po [BANGCONE,PUMP,HARDWARE] $ grenadeLauncher 1
 --    , po [GRENADELAUNCHER 1,MOTOR,DRUM] $ grenadeLauncher 2
 
-    , p [p 2 $ cr PIPE,o $ cr HARDWARE] (bangCaneX 1)
+--    , po [cr PIPE, cr HARDWARE] (volleyGun 1)
-    , p [p 2 $ cr PIPE,o $ BANGCANEX 1] (bangCaneX 2)
+    , po [BANGSTICK 1,cr PLANK] rifle
-    , po [BANGCANEX 1,cr TIN] rifle
+    , p [p 3 $ BANGSTICK 1] (volleyGun 3)
-    , po [RIFLE,cr PLANK]  repeater
+    , po [RIFLE,cr TIN]  repeater
-    , po [REPEATER,cr SPRING,cr HARDWARE] autoRifle
+    , po [REPEATER,cr SPRING] autoRifle
-    , po [REPEATER,cr SPRING,cr CAN] burstRifle
+    , po [REPEATER,cr CAN] burstRifle
-    , po [BURSTRIFLE,cr SPRING,cr HARDWARE] fastBurstRifle
+--    , po [BURSTRIFLE,cr SPRING,cr HARDWARE] fastBurstRifle
-    , po [FASTBURSTRIFLE,cr SPRING,cr HARDWARE] completeBurstRifle
+--    , po [FASTBURSTRIFLE,cr SPRING,cr HARDWARE] completeBurstRifle
-    , po [cr MOTOR,BANGCANEX 3] $ miniGunX 3
+    , po [cr MOTOR,VOLLEYGUN 3] $ miniGunX 3
-    , po [cr MOTOR,BANGCANEX 4] $ miniGunX 4
+    , po [cr MOTOR,VOLLEYGUN 4] $ miniGunX 4
-    , po [cr MOTOR,BANGCANEX 5] $ miniGunX 5
+    , po [cr MOTOR,VOLLEYGUN 5] $ miniGunX 5
-    , po [cr MOTOR,BANGCANEX 6] $ miniGunX 6
+    , po [cr MOTOR,VOLLEYGUN 6] $ miniGunX 6
 
-    , p [p 3 $ cr PIPE,o $ cr HARDWARE] bangRod
+--    , po [BANGSTICK 1,cr TUBE]  elephantGun
-    , po [BANGROD,cr PLANK,cr HARDWARE]  elephantGun
+    , po [AMR,cr PIPE] sniperRifle
-    , po [ELEPHANTGUN,cr HARDWARE,cr PRISM] sniperRifle
+    , po [RIFLE,cr PIPE] amr
-    , po [ELEPHANTGUN,cr HARDWARE,cr TIN] amr
+    , po [AMR,cr SPRING] autoAmr
-    , po [AMR,cr HARDWARE,cr SPRING] autoAmr
+    , po [AMR,cr MOTOR] machineGun
-    , po [BANGROD,cr PLATE,cr DRUM,cr MOTOR] machineGun
 
     , p [p 2 $ cr TUBE,o $ cr HARDWARE] launcher
     , p [p 2 $ cr TUBE,o LAUNCHER] (launcherX 2)
@@ -86,12 +83,13 @@ itemCombinations =
 
     , p [p 2 $ cr PLATE] flatShield
     ] 
-    ++ map (\i -> po [LASGUNWIDE i,cr TRANSFORMER,cr PRISM] $ lasWide (i+1)) [1..9]
+    ++ map (\i -> po [LASGUNWIDE i,cr TRANSFORMER,cr PRISM] $ lasWide (i+1)) [2..9]
-    ++ map (\i -> po [LASGUNWIDE i,cr HARDWARE] $ lasFocus i) [1..10]
+--    ++ map (\i -> po [LASGUNWIDE i,cr HARDWARE] $ lasFocus i) [2..10]
     ++ map (\i -> po [cr PIPE,BANGSTICK i] $ bangStick (i+1)) [1..8]
     ++ map (\i -> po [REVOLVERX i,cr CAN]  $ revolverX (i+1)) [1..5]
-    ++ map (\i -> p [o (BANGCANEX i),p 2 $ cr PIPE] $ bangCaneX (i+1)) [1..5]
+    ++ map (\i -> po [VOLLEYGUN i,BANGSTICK 1] $ volleyGun (i+1)) [3..5]
-    ++ map (\i -> po [MINIGUNX i,BANGCANEX 1] $ miniGunX (i+1)) [3..15]
+    ++ map (\i -> po [MINIGUNX i,BANGSTICK 1] $ miniGunX (i+1)) [3..15]
+    ++ map (\i -> po [GRAPECANNON i,cr DRUM] $ grapeCannon (i+1)) [1,2,3]
 
     ++ [ po (_iyBase (_itType it):mtype) $ it & itType . iyModules . ix modtype .~ m
             | (modtype,is,ms) <- moduleCombinations
@@ -109,8 +107,8 @@ moduleCombinations =
     [   ( ModRifleMag
         ,   [repeater
             ,autoRifle
-            ,burstRifle
+--            ,burstRifle
-            ,fastBurstRifle
+--            ,fastBurstRifle
             ]
         ,   [amod [cr DRUM,cr HARDWARE]  DRUMMAG
             ,amod [cr MOTOR,cr HARDWARE] BELTMAG
@@ -185,19 +183,22 @@ batteryGuns =
     , lasSwing
     ] ++ 
     [ lasWide i | i <- [1..10]
-    ] ++
+    ] 
-    [ lasFocus i | i <- [1..10]]
+--    ++
+--    [ lasFocus i | i <- [1..10]]
 
 teleportableWeapons :: [Item]
 teleportableWeapons  = bulletWeapons ++ batteryGuns ++ homingLaunchers
 
 bulletWeapons :: [Item]
-bulletWeapons = [bangStick i | i <- [1..9] ]
+bulletWeapons 
-    ++ [bangCaneX i | i <- [1..6] ]
+    =  [bangStick i | i <- [1..9] ]
+    ++ [volleyGun i | i <- [3..6] ]
     ++ [revolverX i | i <- [1..5] ]
     ++ [miniGunX  i | i <- [3..16] ]
-    ++ [bangCane
+    ++ [grapeCannon i | i <- [1,2,3,4] ]
-    ,pistol
+    ++ 
+    [pistol
     ,autoPistol
     ,smg
     ,machinePistol
@@ -206,11 +207,14 @@ bulletWeapons = [bangStick i | i <- [1..9] ]
     ,repeater
     ,autoRifle
     ,burstRifle
-    ,fastBurstRifle
+--    ,fastBurstRifle
-    ,completeBurstRifle
+--    ,completeBurstRifle
     ,bangCone
     ,blunderbuss
-    ,bigBlunderbuss
+    ,machineGun
-    ,biggerBlunderbuss
+    ,elephantGun
-    ,biggestBlunderbuss
+    ,sniperRifle
+    ,amr
+    ,autoAmr
+    ,bangRod
     ]

src/Dodge/Combine/Data.hs

@@ -72,31 +72,27 @@ data ItemBaseType
     | EFFGUN String
     | AUTOEFFGUN String
     -- Weapons
-    | BANGSTICK Int
+    | BANGSTICK {_xNum :: Int}
     | PISTOL
     | REVOLVER
-    | REVOLVERX Int
+    | REVOLVERX {_xNum :: Int}
     | MACHINEPISTOL
     | AUTOPISTOL
     | SMG
     | BANGCONE
     | BLUNDERBUSS
-    | BIGBLUNDERBUSS
+    | GRAPECANNON {_xNum :: Int}
-    | BIGGERBLUNDERBUSS
-    | BIGGESTBLUNDERBUSS
---    | GRAPESHOTCANNON
 --    | GRENADELAUNCHER Int -- number of chambers that can be reloaded
 --    | MORTARCONE / HANDMORTAR
-    | BANGCANE
 --    | MINIGUN
-    | MINIGUNX Int
+    | MINIGUNX {_xNum :: Int}
-    | BANGCANEX Int
+    | VOLLEYGUN {_xNum :: Int}
     | RIFLE
     | REPEATER
     | AUTORIFLE
     | BURSTRIFLE
-    | FASTBURSTRIFLE
+--    | FASTBURSTRIFLE
-    | COMPLETEBURSTRIFLE
+--    | COMPLETEBURSTRIFLE
     | BANGROD
     | ELEPHANTGUN
     | AMR
@@ -122,7 +118,7 @@ data ItemBaseType
     | SONICGUN
     | TRACTORGUN
     | LAUNCHER
-    | LAUNCHERX Int
+    | LAUNCHERX {_xNum :: Int}
 --    | TRACKINGLAUNCHER
     | REMOTELAUNCHER
     | POISONSPRAYER
@@ -205,3 +201,4 @@ data ModuleSlot
   deriving (Eq,Ord,Show)
 
 makeLenses ''ItemType
+makeLenses ''ItemBaseType

src/Dodge/Combine/Graph.hs

@@ -0,0 +1,139 @@
+--{-# LANGUAGE TypeSynonymInstances #-}
+--{-# LANGUAGE FlexibleInstances #-}
+module Dodge.Combine.Graph where
+import Dodge.Data hiding (East,West,North,South)
+import Dodge.Combine.Combinations
+import LensHelp
+import GraphHelp
+
+import Data.Text (Text)
+import Data.Text.Lazy (toStrict,pack)
+import qualified Data.Graph.Inductive as FGL
+import GraphVizHelp
+import Data.GraphViz.Attributes.Complete
+import Data.Bifunctor
+
+data CombClust
+    = CraftClust
+    | ItemClust
+    | JoinClust
+  deriving (Eq,Ord,Show,Enum,Bounded)
+
+newtype CombNode = CombNode {_unCombNode :: Either ItemBaseType [(IcAmount,ItemBaseType)]}
+  deriving (Eq,Ord,Show)
+
+instance Labellable CombNode where
+    toLabelValue (CombNode Right{}) = StrLabel (pack "")
+    toLabelValue (CombNode (Left ibt)) = StrLabel (pack $ show ibt)
+
+newtype CombEdge = CombEdge {_unCombEdge :: Int}
+  deriving (Eq,Ord,Show)
+instance Labellable CombEdge where
+    toLabelValue (CombEdge 0) = StrLabel (pack "")
+    toLabelValue (CombEdge x) = StrLabel (pack $ show x)
+
+bulletCombinations :: [([(IcAmount,ItemBaseType)],Item)]
+bulletCombinations = filter 
+    ( (`elem` map totype bulletWeapons)
+    . totype
+    . snd
+    ) itemCombinations
+  where
+    totype = _iyBase . _itType
+
+maxShowX :: ItemBaseType -> Maybe Int
+maxShowX bt = case bt of
+    BANGSTICK _ -> Just 2
+    REVOLVERX _ -> Just 1
+    VOLLEYGUN _ -> Just 3
+    MINIGUNX  _ -> Just 3
+    GRAPECANNON _ -> Just 1
+    LAUNCHERX _ -> Just 2
+--    LASGUNWIDE _ -> Just 2
+--    LASGUNFOCUS _ -> Just 2
+    _ -> Nothing
+
+itemCombinationsEdges :: [(CombNode,CombNode,Int)]
+itemCombinationsEdges = concatMap (f . over _2 (_iyBase . _itType)) itemCombinations
+--itemCombinationsEdges = concatMap (f . over _2 (_iyBase . _itType)) bulletCombinations
+  where
+    f (abts,bt) 
+        | bt `elem` bts = []
+        | any (not . belowNumX) bts = []
+        | otherwise =  (CombNode $ Right abts,CombNode $  Left bt,0) :  map g abts
+      where
+        bts = map snd abts
+        g (am,bt') = (CombNode $ Left bt',CombNode $ Right abts,_toInt am)
+
+combinationsGraph :: FGL.Gr CombNode CombEdge
+combinationsGraph = FGL.labnfilter (f . _unCombNode . snd) 
+    . second CombEdge $ mkGraphFromEdges itemCombinationsEdges
+  where
+    f Right {} = True
+    f (Left (CRAFT _)) = False
+    f (Left bt) = case maxShowX bt of
+        Nothing -> True
+        Just i -> _xNum bt <= i
+
+belowNumX :: ItemBaseType -> Bool
+belowNumX bt = case maxShowX bt of
+    Nothing -> True
+    Just i -> _xNum bt <= i
+
+toCombNodeLabel :: CombNode -> String
+toCombNodeLabel (CombNode (Left ibt)) = show ibt
+toCombNodeLabel (CombNode Right{}) = ""
+
+combinationsDotGraph :: Text
+--combinationsDotGraph = toStrict . printDotGraph . graphToDot nonClusteredParams $ combinationsGraph
+combinationsDotGraph = toStrict . printDotGraph . graphToDot myParams 
+    $ combinationsGraph
+--    $ first toCombNodeLabel combinationsGraph
+
+myParams :: GraphvizParams Int CombNode CombEdge CombClust CombNode
+myParams = defaultParams -- {globalAttributes = [GraphAttrs [RankDir FromLeft]]}
+    & isDirectedL .~ True
+--    & globalAttributesL .~ [GraphAttrs [RankDir FromLeft,Splines PolyLine]]
+    & globalAttributesL .~ [GraphAttrs [RankDir FromLeft]]
+    & clusterByL .~ clusterFunc
+    & isDotClusterL .~ (const False)
+    & clusterIDL .~ setClusterID
+    & fmtClusterL .~ clusterFormatting
+    & fmtEdgeL .~ edgeFormatting
+    & fmtNodeL .~ nodeFormatting
+
+setClusterID :: CombClust -> GraphID
+setClusterID = Num . Int . fromEnum
+
+clusterFunc :: (Int,CombNode) -> NodeCluster CombClust (Int,CombNode)
+clusterFunc n@(_,CombNode (Left bt)) = case bt of
+    CRAFT _ -> C CraftClust (N n)
+    _ -> C ItemClust (N n)
+clusterFunc n = C JoinClust (N n)
+
+clusterFormatting :: CombClust -> [GlobalAttributes]
+clusterFormatting cl = case cl of
+--    CraftClust -> [GraphAttrs [Rank SameRank]]
+    _ -> []
+
+edgeFormatting :: (Int,Int,CombEdge) -> Attributes
+--edgeFormatting (_,_,CombEdge 0) = []
+--     [ArrowHead (AType [(ArrMod OpenArrow BothSides ,NoArrow)])
+--    ,SameTail (pack "b")
+--    ]
+edgeFormatting (_,_,ce) = case _unCombEdge ce of
+    0 -> [ xLabel ce
+        , TailPort (CompassPoint East)
+        ]
+    _ -> [ xLabel ce
+        , ArrowHead (AType [(ArrMod OpenArrow BothSides ,NoArrow)])
+        , HeadPort (CompassPoint West)
+        ]
+
+
+nodeFormatting :: (Int,CombNode) -> Attributes
+nodeFormatting (_,CombNode Right {}) = [Shape PointShape]
+nodeFormatting (_,CombNode cn@(Left bt)) = case bt of
+    --CRAFT _ -> [Shape DiamondShape,toLabel (CombNode cn)]
+    CRAFT _ -> [Color [WC (X11Color Green) Nothing],toLabel (CombNode cn)]
+    _ -> [Shape BoxShape,toLabel (CombNode cn)]

src/Dodge/Combine/Trie.hs

@@ -0,0 +1,19 @@
+module Dodge.Combine.Trie where
+import Dodge.Combine.Combinations
+import Dodge.Data
+--import Dodge.Combine.Module
+--import Dodge.Combine.Data
+--import Multiset
+import SimpleTrie
+
+import Data.Bifunctor
+--import qualified Data.IntSet as IS
+--import Data.Map.Merge.Strict
+import Data.List (sort)
+
+combinationsTrie :: Trie (IcAmount,ItemBaseType) Item
+{-# INLINE combinationsTrie #-}
+combinationsTrie = foldr 
+    (uncurry insertInTrie . first sort) 
+    emptyTrie
+    itemCombinations

src/Dodge/Creature.hs

@@ -97,7 +97,7 @@ multGunCrit :: Creature
 multGunCrit = defaultCreature
     { _crPict = basicCrPict
 --    , _crUpdate = stateUpdate (twitchMissAI 300 350)
-    , _crInv = IM.fromList [(0,bangCaneX 4),(1,medkit 100)]
+    , _crInv = IM.fromList [(0,volleyGun 4),(1,medkit 100)]
     , _crRad = 10
     , _crHP = 300
     , _crUpdate = defaultImpulsive [sentinelExtraWatchUpdate
@@ -227,6 +227,20 @@ inventoryX c = case c of
     'I' -> [ makeTypeCraft TELEPORTMODULE
            , makeTypeCraftNum 2 MICROCHIP 
            ]
+    'J' -> [ lasGun
+            , lasSwing
+            , lasDual
+            , lasWide 1
+            , lasWide 2
+            , lasWide 3
+            , lasWide 4
+            , lasWide 5
+            , lasWidePulse
+            , lasFocus 1
+            , lasFocus 2
+            , lasFocus 3
+            , lasFocus 6
+            ]
     _ -> []
 
 testInventory :: IM.IntMap Item

src/Dodge/Data.hs

@@ -649,6 +649,7 @@ data Particle
         , _ptDamage :: Int
         , _ptColor  :: Color
         , _ptPhaseV :: Float
+        , _ptPoints :: [Point2]
         }
     | LinearParticle 
         { _ptDraw :: Particle -> Picture

src/Dodge/Data/PathGraph.hs.orig

@@ -0,0 +1,36 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE StrictData #-}
+module Dodge.Data.PathGraph where
+import Geometry.Data
+import Control.Lens
+import Data.Graph.Inductive
+import qualified Data.Set as Set
+import Data.Map.Strict (Map)
+data PathGraph = PathGraph
+    { _pgGraph      :: Gr Point2 PathEdge
+    , _pgNodeMap    :: Map Point2 Int
+    , _pgNodeCount  :: Int
+    , _pgEdgeMap    :: Map (V2 Point2) (Int,Int,PathEdge)
+    }
+data PathEdge = PathEdge
+    {_peStart :: Point2
+    ,_peEnd   :: Point2
+<<<<<<< HEAD
+=======
+    ,_peDist  :: Float
+>>>>>>> efficientRuntime
+    ,_peObstacles :: Set.Set EdgeObstacle
+    }
+  deriving (Eq,Ord,Show)
+data EdgeObstacle
+    = BlockObstacle
+    | DoorObstacle
+    | AutoDoorObstacle
+    | WallObstacle
+  deriving (Eq,Ord,Show,Bounded,Enum)
+
+makeLenses ''PathGraph
+<<<<<<< HEAD
+=======
+makeLenses ''PathEdge
+>>>>>>> efficientRuntime

src/Dodge/Default/Block.hs.orig

@@ -0,0 +1,24 @@
+module Dodge.Default.Block where
+import Dodge.Data
+import Dodge.Block.Debris
+import LensHelp
+
+defaultBlock :: Block
+defaultBlock = Block
+    { _blID = 0
+    , _blWallIDs = mempty
+    , _blHP = 1000
+    , _blShadows = []
+    , _blFootprint = []
+    , _blPos       = 0
+    , _blDir       = 0
+    , _blDraw      = const mempty
+    , _blDeath     = makeBlockDebris
+    , _blObstructs = []
+<<<<<<< HEAD
+=======
+    , _blPaths      = []
+>>>>>>> efficientRuntime
+    }
+defaultDirtBlock :: Block
+defaultDirtBlock = defaultBlock & blHP .~ 50

src/Dodge/Default/World.hs.orig

@@ -0,0 +1,140 @@
+module Dodge.Default.World where
+import Dodge.Data
+import Dodge.Zone.Size
+import Dodge.Zone.Object
+import Dodge.Base
+import Geometry.Vector3D
+import Geometry.Zone
+--import Dodge.Config.KeyConfig
+--import Dodge.Menu
+--import Picture
+import Geometry.Data
+import Geometry.Polygon
+--import Picture.Texture
+--import Data.Preload
+
+import Control.Lens
+import System.Random
+import qualified Data.IntMap.Strict as IM
+import qualified Data.Map as M
+import qualified Data.Set as S
+import Data.Graph.Inductive.Graph hiding ((&))
+--import Data.Graph.Inductive.NodeMap
+--import qualified Data.Vector.Fusion.Stream.Monadic as VS
+defaultWorld :: World
+defaultWorld = World
+    { _keys = S.empty
+    , _magnets = IM.empty
+    , _mouseButtons = mempty
+    , _cameraCenter = V2 0 0
+    , _cameraRot = 0
+    , _cameraZoom = 1
+    , _itemZoom     = 1
+    , _defaultZoom = 1
+    , _cameraViewFrom = V2 0 0
+    , _viewDistance = 1000
+    , _modifications    = IM.empty
+    , _creatures        = IM.empty
+    , _crZoning         = Zoning IM.empty crZoneSize zoneOfCreature
+    , _creatureGroups   = IM.empty
+    , _clouds           = mempty
+    , _clZoning         = Zoning IM.empty clZoneSize (zonePos (stripZ . _clPos))
+    , _gusts = IM.empty
+    , _gsZoning         = Zoning IM.empty clZoneSize (zonePos _guPos)
+    , _itemPositions = IM.empty
+    , _props = IM.empty
+    , _instantParticles = []
+    , _particles = []
+    , _newBeams = WorldBeams [] [] [] []
+    , _beams = WorldBeams [] [] [] []
+    , _walls = IM.empty
+    , _wallDamages = IM.empty
+    , _blocks = IM.empty
+    , _machines = IM.empty
+    , _terminals = IM.empty
+    , _doors = IM.empty
+    , _coordinates  = IM.empty
+    , _triggers     = IM.empty
+    , _wlZoning     = Zoning IM.empty wlZoneSize zoneOfWall
+    , _floorItems = IM.empty
+    , _floorTiles = []
+    , _randGen = mkStdGen 2
+    , _mousePos = V2 0 0
+    , _testString = const . const []
+    , _debugPicture = mempty
+    , _yourID = 0
+    , _worldEvents = id
+    , _delayedEvents = []
+    , _pressPlates = IM.empty
+    , _buttons = IM.empty
+    , _toPlaySounds = M.empty
+    , _playingSounds = M.empty
+    , _corpses = IM.empty
+    , _decorations = IM.empty
+    --, _savedWorlds = M.empty
+--    , _menuLayers = []
+    , _clickMousePos = V2 0 0
+    , _pathGraph = PathGraph Data.Graph.Inductive.Graph.empty mempty 0 mempty
+    , _pathGraphP   = mempty
+<<<<<<< HEAD
+    , _pnZoning     = Zoning mempty pnZoneSize (zonePos snd)
+    , _peZoning     = Zoning mempty pnZoneSize (\x (_,_,PathEdge p q _) -> zoneOfSeg x p q)
+=======
+    , _pnZoning     = Zoning mempty wlZoneSize (zonePos snd)
+    , _peZoning     = Zoning mempty wlZoneSize (\x (_,_,e) -> zoneOfSeg x (_peStart e) (_peEnd e))
+>>>>>>> efficientRuntime
+    , _hud = HUD
+        { _hudElement = DisplayInventory NoSubInventory
+        , _carteCenter = V2 0 0
+        , _carteZoom = 0.5
+        , _carteRot  = 0
+        }
+    , _lightSources = IM.empty
+    , _tempLightSources = [youLight]
+    , _closeObjects     = []
+    , _rbOptions        = NoRightButtonOptions
+    , _seenLocations        = IM.fromList 
+        [(0, (_crPos . you, "CURRENT POSITION"))
+        ,(1, (const (V2 0 0) , "START POSITION"))
+        ]
+    , _selLocation = 0
+    --, _keyConfig = defaultKeyConfigSDL
+--    , _config       = defaultConfig
+    , _sideEffects  = return
+    , _shapes = mempty
+    , _distortions     = []
+    , _gameRooms = []
+    , _roomClipping = []
+    , _worldClock = 0
+    , _worldBounds = defaultBounds
+    , _maybeWorld = Nothing'
+    , _rewindWorlds = []
+    , _timeFlow = NormalTimeFlow
+    , _hammers = defaultWorldHammers
+    , _backspaceTimer = 0
+    , _genParams = GenParams M.empty
+    , _genPlacements = IM.empty
+    , _genRooms = IM.empty
+    , _deathDelay = Nothing
+    , _testFloat = 0
+    , _boundBox = square 100
+    , _boundDist = (100,-100,100,-100)
+    , _lLine  = (0,0)
+    , _rLine  = (0,0)
+    , _lSelect   = 0
+    , _rSelect   = 0
+    }
+defaultWorldHammers :: M.Map WorldHammer HammerPosition
+defaultWorldHammers = M.fromSet (const HammerUp) $ S.fromList [minBound.. maxBound]
+youLight :: TempLightSource
+youLight = TLS 
+    { _tlsParam = LSParam
+        {_lsPos = V3 0 0 0
+        ,_lsRad = 300
+        ,_lsCol = 0.1
+        }
+    ,_tlsUpdate = \w _ -> Just (youLight & tlsParam . lsPos .~ f (_crPos $ you w))
+    ,_tlsTime = 0
+    }
+  where
+    f (V2 x y) = V3 x y 100

src/Dodge/Floor.hs

@@ -41,6 +41,7 @@ initialAnoTree :: Annotation
 initialAnoTree = OnwardList 
         $ intersperse (AnTree corDoor)
     [ IntAnno $ AnTree . startRoom
+    , AnRoom $ roomCCrits 0
     , AnRoom $ return airlock0
     , AnRoom slowDoorRoom
     , AnRoom $ roomCCrits 10

src/Dodge/Item.hs

@@ -31,21 +31,17 @@ itemFromBase ibt = case ibt of
     SMG     -> smg
     BANGCONE    -> bangCone
     BLUNDERBUSS     -> blunderbuss
-    BIGBLUNDERBUSS  -> bigBlunderbuss
+    GRAPECANNON i  -> grapeCannon i
-    BIGGERBLUNDERBUSS   -> biggerBlunderbuss
-    BIGGESTBLUNDERBUSS  -> biggestBlunderbuss
---    GRAPESHOTCANNON     -> grapeShotCannon
     --GRENADELAUNCHER Int -- number of chambers that can be reloaded
 --  --| MORTARCONE / HANDMORTAR
-    BANGCANE    -> bangCane
     MINIGUNX i    -> miniGunX i
-    BANGCANEX i   -> bangCaneX i 
+    VOLLEYGUN i   -> volleyGun i 
     RIFLE   -> rifle
     REPEATER    -> repeater
     AUTORIFLE   -> autoRifle
     BURSTRIFLE  -> burstRifle
-    FASTBURSTRIFLE  -> fastBurstRifle
+--    FASTBURSTRIFLE  -> fastBurstRifle
-    COMPLETEBURSTRIFLE  -> completeBurstRifle
+--    COMPLETEBURSTRIFLE  -> completeBurstRifle
     BANGROD     -> bangRod
     ELEPHANTGUN     -> elephantGun
     AMR     -> amr
@@ -175,22 +171,18 @@ baseToFamily ibt = case ibt of
     SMG                 -> HeldFamily
     BANGCONE            -> HeldFamily
     BLUNDERBUSS         -> HeldFamily
-    BIGBLUNDERBUSS      -> HeldFamily
+    GRAPECANNON _       -> HeldFamily
-    BIGGERBLUNDERBUSS   -> HeldFamily
-    BIGGESTBLUNDERBUSS  -> HeldFamily
---  | GRAPESHOTCANNON   -> HeldFamily
 --  | GRENADELAUNCHER In-> HeldFamilyt -- number of chambers that can be reloaded
 --  | MORTARCONE / HANDM-> HeldFamilyORTAR
-    BANGCANE            -> HeldFamily
 --  | MINIGUN           -> HeldFamily
     MINIGUNX _        -> HeldFamily
-    BANGCANEX _       -> HeldFamily
+    VOLLEYGUN _       -> HeldFamily
     RIFLE               -> HeldFamily
     REPEATER            -> HeldFamily
     AUTORIFLE           -> HeldFamily
     BURSTRIFLE          -> HeldFamily
-    FASTBURSTRIFLE      -> HeldFamily
+--    FASTBURSTRIFLE      -> HeldFamily
-    COMPLETEBURSTRIFLE  -> HeldFamily
+--    COMPLETEBURSTRIFLE  -> HeldFamily
     BANGROD             -> HeldFamily
     ELEPHANTGUN         -> HeldFamily
     AMR                 -> HeldFamily

src/Dodge/Item/Random.hs

@@ -5,4 +5,4 @@ import Dodge.Item.Weapon.BulletGuns
 
 
 randBlockBreakWeapon :: RandomGen g => State g Item
-randBlockBreakWeapon = takeOne [bangStick 1,bangCane]
+randBlockBreakWeapon = takeOne [bangStick 1]

src/Dodge/Item/Weapon/BatteryGuns.hs

@@ -433,7 +433,7 @@ basicBeamAt itid w col dam phasev pos dir = Beam
     , _bmType = BeamCombine $ const id
     }
   where
-    (_,ps) = reflectLaserAlong phasev [] pos (pos +.+ 800 *.* unitVectorAtAngle dir) w
+    (_,ps) = reflectLaserAlong phasev pos (pos +.+ 800 *.* unitVectorAtAngle dir) w
 
 dualRayAt :: BeamType -> Int -> World -> Color -> Int -> Float -> Point2 -> Float -> Beam
 dualRayAt bt itid w col dam phasev pos dir = basicBeamAt itid w col dam phasev pos dir

src/Dodge/Item/Weapon/BulletGun/Cane.hs

@@ -1,12 +1,11 @@
 module Dodge.Item.Weapon.BulletGun.Cane 
-    ( bangCane
+    ( volleyGun
-    , bangCaneX
     , repeater
     , rifle
     , autoRifle
     , burstRifle
-    , completeBurstRifle
+--    , completeBurstRifle
-    , fastBurstRifle
+--    , fastBurstRifle
     , miniGunX
     ) where
 --import Dodge.Particle.Bullet.HitEffect
@@ -31,14 +30,8 @@ import Shape
 import Sound.Data
 import LensHelp
 
---import qualified Data.Map.Strict as M
+defaultBangCane :: Item
---import qualified Data.Sequence as Seq
+defaultBangCane = defaultBulletWeapon
---import Control.Lens
---import Control.Monad.State
---import System.Random
-
-bangCane :: Item
-bangCane = defaultBulletWeapon
     { _itParams = BulletShooter
         { _muzVel = 0.8
         , _rifling = 0.9
@@ -72,11 +65,11 @@ bangCane = defaultBulletWeapon
             <> makeSingleClipAt (V3 5 0 3) it
         }
     } & itUse . useAim . aimStance .~ OneHand
-    & itType . iyBase .~ BANGCANE
+    & itType . iyBase .~ error "undefined bangCane baseitemtype"
     & itConsumption . laMax .~ 1
     & itConsumption . laCycle .~ [loadPartialInsert 10 1]
-bangCaneX :: Int -> Item
+volleyGun :: Int -> Item
-bangCaneX i = defaultBulletWeapon
+volleyGun i = defaultBulletWeapon
     & itUse .~ ruseAmmoParamsRate 6 upHammer
         [ ammoHammerCheck
         , useTimeCheck
@@ -123,7 +116,7 @@ bangCaneX i = defaultBulletWeapon
         ,_brlInaccuracy = 0.1
         }
     & itParams . torqueAfter .~ 0.48 + 0.2 * fromIntegral i
-    & itType . iyBase .~ BANGCANEX i
+    & itType . iyBase .~ VOLLEYGUN i
 caneStickSoundChoice :: Item -> SoundID
 caneStickSoundChoice it
     | _laLoaded (_itConsumption it) < 2 = tap3S 
@@ -136,7 +129,7 @@ caneClipX i it = case  it ^? itConsumption . laLoaded of
             [0..la-1]
     _ -> mempty
 rifle :: Item
-rifle = bangCane
+rifle = defaultBangCane
     { _itDimension = ItemDimension
         { _dimRad = 8
         , _dimCenter = V3 5 0 0
@@ -195,41 +188,41 @@ burstRifle = repeater
         , withMuzFlareI
         , withRecoil
         ]
-fastBurstRifle :: Item
+--fastBurstRifle :: Item
-fastBurstRifle = repeater
+--fastBurstRifle = repeater
-    & itType . iyBase .~ FASTBURSTRIFLE
+--    & itType . iyBase .~ FASTBURSTRIFLE
-    & itParams . gunBarrels . brlInaccuracy .~ 0.06
+--    & itParams . gunBarrels . brlInaccuracy .~ 0.06
-    & itUse . useDelay . rateMax .~ 18
+--    & itUse . useDelay . rateMax .~ 18
-    & itUse . useMods .~
+--    & itUse . useMods .~
-        [ ammoHammerCheck
+--        [ ammoHammerCheck
-        , useTimeCheck
+--        , useTimeCheck
-        , sideEffectOnFrame 9 (torqueSideEffect 0.4)
+--        , sideEffectOnFrame 9 (torqueSideEffect 0.4)
-        , lockInvFor 9
+--        , lockInvFor 9
-        , \f it -> repeatOnFrames (take (_laLoaded (_itConsumption it) - 1) [2,4,6,8]) f it
+--        , \f it -> repeatOnFrames (take (_laLoaded (_itConsumption it) - 1) [2,4,6,8]) f it
-        , withSoundStart tap3S
+--        , withSoundStart tap3S
-        , useAmmoAmount 1
+--        , useAmmoAmount 1
-        , applyInaccuracy
+--        , applyInaccuracy
-        , withMuzFlareI
+--        , withMuzFlareI
-        , withRecoil
+--        , withRecoil
-        ]
+--        ]
-completeBurstRifle :: Item
+--completeBurstRifle :: Item
-completeBurstRifle = repeater
+--completeBurstRifle = repeater
-    & itType . iyBase .~ COMPLETEBURSTRIFLE
+--    & itType . iyBase .~ COMPLETEBURSTRIFLE
-    & itType . iyModules . at ModRifleMag .~ Nothing
+--    & itType . iyModules . at ModRifleMag .~ Nothing
-    & itParams . gunBarrels . brlInaccuracy .~ 0.1
+--    & itParams . gunBarrels . brlInaccuracy .~ 0.1
-    & itUse . useDelay . rateMax .~ 28
+--    & itUse . useDelay . rateMax .~ 28
-    & itUse . useMods .~
+--    & itUse . useMods .~
-        [ ammoHammerCheck
+--        [ ammoHammerCheck
-        , useTimeCheck
+--        , useTimeCheck
-        , sideEffectOnFrame 15 (torqueSideEffect 0.8)
+--        , sideEffectOnFrame 15 (torqueSideEffect 0.8)
-        , lockInvFor 15
+--        , lockInvFor 15
-        , \f it -> repeatOnFrames (take (_laLoaded (_itConsumption it) - 1) [1..14]) f it
+--        , \f it -> repeatOnFrames (take (_laLoaded (_itConsumption it) - 1) [1..14]) f it
-        , withSoundStart tap3S
+--        , withSoundStart tap3S
-        , useAmmoAmount 1
+--        , useAmmoAmount 1
-        , applyInaccuracy
+--        , applyInaccuracy
-        , withMuzFlareI
+--        , withMuzFlareI
-        , withRecoil
+--        , withRecoil
-        ]
+--        ]
 miniGunUse :: Int -> ItemUse
 miniGunUse i = ruseInstant (useAmmoParams $ Just 1) NoHammer $
     [ ammoCheckI

src/Dodge/Item/Weapon/BulletGuns.hs

@@ -1,9 +1,7 @@
 module Dodge.Item.Weapon.BulletGuns
     ( bangCone
     , blunderbuss
-    , bigBlunderbuss
+    , grapeCannon
-    , biggerBlunderbuss
-    , biggestBlunderbuss
     , grenadeLauncher
     , autogunSpread
     , autoGun
@@ -164,30 +162,14 @@ blunderbuss = bangCone
     & itUse . useAim . aimStance .~ TwoHandTwist
     & itUse . useAim . aimWeight .~ 6
     & itType . iyBase .~ BLUNDERBUSS
-bigBlunderbuss :: Item
+grapeCannon :: Int -> Item
-bigBlunderbuss = blunderbuss
+grapeCannon i = blunderbuss
-    & itType . iyBase .~ BIGBLUNDERBUSS
+    & itType . iyBase .~ GRAPECANNON i
-    & itConsumption . laMax .~ 50
+    & itConsumption . laMax .~ 25 + 25 * i
-    & itConsumption . laCycle .~ [loadEject 5, loadInsert 40 , loadPrime 5]
+    & itConsumption . laCycle .~ [loadEject 5, loadInsert (30 + i * 10) , loadPrime 5]
-    & itParams . recoil .~ 200
+    & itParams . recoil .~ (150 + fromIntegral i * 50)
-    & itParams . torqueAfter .~ 0.3
+    & itParams . torqueAfter .~ (0.1 + 0.2 * fromIntegral i)
-    & itParams . randomOffset .~ 16
+    & itParams . randomOffset .~ (12 + 4 * fromIntegral i)
-biggerBlunderbuss :: Item
-biggerBlunderbuss = bigBlunderbuss
-    & itType . iyBase .~ BIGGERBLUNDERBUSS
-    & itConsumption . laMax .~ 75
-    & itConsumption . laCycle .~ [loadEject 5, loadInsert 50 , loadPrime 5]
-    & itParams . recoil .~ 250
-    & itParams . torqueAfter .~ 0.5
-    & itParams . randomOffset .~ 20
-biggestBlunderbuss :: Item
-biggestBlunderbuss = biggerBlunderbuss
-    & itType . iyBase .~ BIGGESTBLUNDERBUSS
-    & itConsumption . laMax .~ 100
-    & itConsumption . laCycle .~ [loadEject 5, loadInsert 60 , loadPrime 5]
-    & itParams . recoil .~ 300
-    & itParams . torqueAfter .~ 0.7
-    & itParams . randomOffset .~ 24
 
 grenadeLauncher :: Int -> Item
 grenadeLauncher _ = bangCone

src/Dodge/Item/Weapon/ExtraEffect.hs

@@ -195,7 +195,7 @@ targetLaserUpdate _ cr w t
         & tgActive .~ False
         )
   where
-    (mp, ps) = reflectLaserAlong 0.2 [] sp ep w
+    (mp, ps) = reflectLaserAlong 0.2 sp ep w
     sp = _crPos cr +.+ 15 *.* unitVectorAtAngle (_crDir cr)
     ep = sp +.+ 5000 *.* normalizeV (mouseWorldPos w -.- sp)
     addLaserPic = instantParticles .:~ Particle

src/Dodge/Item/Weapon/LaserPath.hs

@@ -11,27 +11,29 @@ import Geometry
 --import Data.List
 import Data.Bifunctor
 import Data.Tuple
-import Streaming
+--import Streaming
-import qualified Streaming.Prelude as S
+--import qualified Streaming.Prelude as S
 
 -- not sure why we need to keep a list of seen walls, but seems to loop
 -- infinitely when removed
 -- this needs to be tested with both reflections and refractions
-reflectLaserAlong :: Float -> [Wall] -> Point2 -> Point2 -> World 
+-- the distance of the laser should be limited
+reflectLaserAlong :: Float -> Point2 -> Point2 -> World 
     -> (Maybe (Point2,Either Creature Wall),[Point2])
-reflectLaserAlong phasev seenWl sp ep w = case runIdentity . S.head_ . S.dropWhile (notseen seenWl) 
+reflectLaserAlong phasev sp ep w = case thingHit sp ep w of
-        $ thingsHitExceptCr Nothing sp ep w of
     Just (p,Right wl) 
-        | _wlReflect wl -> second (p:) $ reflectLaserAlong phasev (wl:seenWl) p 
+        | _wlReflect wl -> second (p:) $ reflectLaserAlong phasev 
-            (p +.+ 800 *.* unitVectorAtAngle (reflDirWall sp p wl)) w
+            (p +.+ unitVectorAtAngle (reflDirWall sp p wl))
-        | wlIsSeeThrough wl -> second (p:) $ reflectLaserAlong phasev (wl:seenWl) p 
+            (p +.+ (dist p ep) *.* unitVectorAtAngle (reflDirWall sp p wl)) 
-            (refract sp ep wl p) w
+            w
+        | wlIsSeeThrough wl && _wlSeen wl -> second (p:) $ reflectLaserAlong phasev 
+            (p +.+ normalizeV (refract sp ep wl p))
+            (refract sp ep wl p) 
+            w
         | otherwise -> (Just (p,Right wl), [p])
     Just (p,obj) -> (Just (p,obj), [p])
     Nothing -> (Nothing, [ep])
   where
-    notseen ws (_,Right wl) = not $ any (\w' -> _wlID w' == _wlID wl) ws
-    notseen _ _ = True
     refract x y wl p 
         | isEntering = p +.+ rotateV angleRef  (normalDist wlNormal)
         | otherwise  = p +.+ rotateV angleRef' (normalDist wlNormal')

src/Dodge/Layout.hs.orig

@@ -0,0 +1,267 @@
+--{-# LANGUAGE TupleSections #-}
+module Dodge.Layout 
+    ( generateLevelFromRoomList
+    ) where
+import Data.Tile
+import Dodge.Data
+import Dodge.Path
+import Dodge.Zone.Update
+import Dodge.ShiftPoint
+import Dodge.Placement.PlaceSpot
+--import Dodge.LevelGen.Data
+import Dodge.LevelGen.StaticWalls
+import Dodge.LevelGen.LevelStructure
+import Dodge.Wall.Zone
+import Dodge.GameRoom
+import Dodge.Default.Wall
+import Dodge.Room.Link
+import Dodge.Randify
+import Geometry
+--import Geometry.ConvexPoly
+import qualified IntMapHelp as IM
+import Tile
+import RandomHelp
+
+import Data.Graph.Inductive (labNodes,labEdges)
+import Data.List (nubBy)
+import Data.Traversable
+import Control.Lens
+import Data.Foldable
+import qualified Control.Foldl as L
+import Data.Maybe
+import Data.Function
+
+generateLevelFromRoomList :: IM.IntMap Room -> World -> World
+generateLevelFromRoomList gr' w = initWallZoning 
+    . randomCompass
+    . setupWorldBounds
+    . doAfterPlacements
+    . doInPlacements
+    . doOutPlacements
+    . doIndividualPlacements
+    . setFloors
+    . worldToGenWorld rs'
+    $ w { _walls        = wallsFromRooms rs
+        , _gameRooms    = gameRoomsFromRooms (IM.elems rs')
+        , _pathGraph    = path
+        , _pathGraphP   = pairPath
+        }
+        & pnZoning   %~ (\zn -> foldl' (flip $ updateZoning (:)) (zn & znObjects .~ mempty)
+<<<<<<< HEAD
+            (labNodes (_pgGraph path)))
+        & peZoning   %~ (\zn -> foldl' (flip $ updateZoning (:)) (zn & znObjects .~ mempty)
+            (labEdges (_pgGraph path)))
+  where
+    path = pairsToGraph pairPath
+=======
+            (labNodes path))
+        & peZoning   %~ (\zn -> foldl' (flip $ updateZoning (:)) (zn & znObjects .~ mempty)
+            (labEdges path))
+  where
+    (_,path) = pairsToGraph pairPath
+>>>>>>> efficientRuntime
+    pairPath = foldMap _rmPath rs
+    rs = map doRoomShift $ IM.elems rs'
+    rs'= mapM shuffleRoomPos gr' & evalState $ _randGen w
+
+randomCompass :: World -> World
+randomCompass w = w & cameraRot .~ (takeOne [0,0.5*pi,pi,1.5*pi] & evalState $ _randGen w)
+
+putFloorTiles :: World -> World
+putFloorTiles gw = gw & floorTiles .~ floorsFromGenWorld gw
+
+setFloors :: World -> World
+setFloors = putFloorTiles . setTiles
+
+-- note the order of traversal of the rooms is important
+-- hence the reverse
+-- this is not ideal: should do this in some more sensible way
+setTiles :: World -> World
+setTiles gw = foldr setTile gw . reverse . IM.elems $ _genRooms gw
+
+setTile :: Room -> World -> World
+setTile r gw = case _rmFloor r of
+    Tiled {} -> gw
+    InheritFloor -> gw & genRooms . ix (fromJust (_rmMID r)) . rmFloor .~ Tiled [t & tilePoly .~ poly]
+  where
+    t = case _rmMParent r of
+        Nothing -> Tile poly (V2 0 0) (V2 1 0) 16
+        Just pid -> head $ _tiles $ _rmFloor $ _genRooms gw IM.! pid
+    poly = orderPolygon . convexHullSafe . nubBy ((==) `on` roundPoint2) $ concat $ _rmPolys r
+
+shuffleRoomPos :: RandomGen g => Room -> State g Room
+shuffleRoomPos rm = do
+    newPos <- shuffle $ _rmPos rm
+    return $ rm & rmPos .~ newPos
+
+doAfterPlacements :: World -> World
+doAfterPlacements gw = foldr doAfterPlacement gw (_genPlacements gw)
+
+doAfterPlacement :: [(Placement,Int)] -> World -> World
+doAfterPlacement pmntis gw = gRandify gw $ do
+    (pmnt,i) <- takeOne pmntis
+    let (newgw,rm) = fst $ placeSpot (gw,_genRooms gw IM.! i) pmnt
+    return $ newgw & genRooms . ix i .~ rm
+
+doInPlacements :: ( IM.IntMap [Placement],World) -> World
+doInPlacements (im,w) = 
+    let (gw,rms) = mapAccumR (doRoomInPlacements im) w (_genRooms w)
+    in gw & genRooms .~ rms
+
+doRoomInPlacements :: IM.IntMap [Placement] -> World -> Room -> (World, Room)
+doRoomInPlacements im w rm = foldr f (w,rm) $ _rmInPmnt rm
+  where
+    f (InPlacement plf i) (w',r') = fst $ placeSpot (w',r') (plf $ im IM.! i)
+
+doOutPlacements :: World -> ( IM.IntMap [Placement], World)
+doOutPlacements w = let ((pmnts,gw),rms) = mapAccumR doRoomOutPlacements (IM.empty,w) (_genRooms w)
+    in (pmnts,gw & genRooms .~ rms)
+
+doRoomOutPlacements :: (IM.IntMap [Placement], World) 
+    -> Room 
+    -> ( (IM.IntMap [Placement], World) , Room )
+doRoomOutPlacements imw r = foldr f ( imw, r ) $ _rmOutPmnt r
+  where
+    f (OutPlacement pl i) ( (im,w) , rm ) = 
+        let ((neww,newrm),plmnts) = placeSpot (w,rm) pl
+        in ((IM.insert i plmnts im, neww) , newrm )
+
+doIndividualPlacements :: World -> World
+doIndividualPlacements gw = let (gw', rms) = mapAccumR doRoomPlacements gw (_genRooms gw)
+    in gw' & genRooms .~ rms
+
+doRoomPlacements :: World -> Room -> (World, Room)
+doRoomPlacements w rm = foldl' (\wr -> fst . placeSpot wr) (w,rm) $ _rmPmnts rm
+
+setupWorldBounds :: World -> World
+setupWorldBounds w = w & worldBounds %~
+    ( (bdMinX .~ f minx)
+    . (bdMaxX .~ f maxx)
+    . (bdMinY .~ f miny)
+    . (bdMaxY .~ f maxy)
+    )
+  where
+    f = fromMaybe 0
+    ps = IM.map (fst . _wlLine) $ _walls w
+    (minx,maxx,miny,maxy) = L.fold ((,,,) 
+        <$> L.premap fstV2 L.minimum
+        <*> L.premap fstV2 L.maximum
+        <*> L.premap sndV2 L.minimum
+        <*> L.premap sndV2 L.maximum
+        ) ps
+
+--polyhedrasToEdges :: [Polyhedra] -> [Point3]
+--polyhedrasToEdges = concatMap tflat4 . concatMap polyToEdges
+
+initWallZoning :: World -> World
+initWallZoning w = foldl' (flip insertWallInZones) (w & wlZoning . znObjects .~ IM.empty) (_walls w)
+
+--makePath :: Tree Room -> [(Point2,Point2)]
+--makePath = concatMap _rmPath . flatten
+
+wallsFromRooms :: [Room] -> IM.IntMap Wall
+wallsFromRooms = --    divideWalls .
+    IM.fromAscList 
+    . zipWith f [0..] 
+    . removeInverseWalls 
+    . foldl' (flip cutWalls) [] 
+    . concatMap _rmPolys
+  where
+    f i (x,y) = (i, defaultWall {_wlLine = (x,y) , _wlID = i})
+
+-- TODO sort out shifting before or after etc
+gameRoomsFromRooms :: [Room] -> [GameRoom]
+gameRoomsFromRooms = fmap gameRoomFromRoom
+
+gameRoomFromRoom :: Room -> GameRoom
+gameRoomFromRoom rm = GameRoom
+    { _grViewpoints = map doshift $ _rmViewpoints rm ++ (map fst . foldl' (flip cutWalls) [] $ _rmPolys rm)
+        ++ mapMaybe filterUnusedLinks (_rmPos rm)
+    , _grViewpointsEx = concatMap filterUsedLinks (_rmPos rm)
+    , _grBound = map doshift $ expandPolyCorners 50 . convexHullSafe . nubBy closePoints 
+        . concat $ _rmBound rm ++ _rmPolys rm
+    , _grDir   = getDir $ _rmPos rm
+    , _grLinkDirs = mapMaybe undir $ _rmPos rm
+    , _grName  = _rmName rm
+    }
+  where
+    doshift = shiftPointBy (_rmShift rm)
+    doubleShift p a = map doshift
+        [p +.+ 10 *.* unitVectorAtAngle a
+        ,p -.- 10 *.* unitVectorAtAngle a
+        ]
+    filterUnusedLinks rp = case _rpLinkStatus rp of
+        UnusedLink{} -> Just $ _rpPos rp
+        _ -> Nothing
+    filterUsedLinks rp = case _rpLinkStatus rp of
+        UsedOutLink{} -> doubleShift (_rpPos rp) (_rpDir rp)
+        UsedInLink{} -> doubleShift (_rpPos rp) (_rpDir rp)
+        _ -> []
+    undir rp = case _rpLinkStatus rp of
+        UsedOutLink{} -> ma
+        UsedInLink{}  -> ma
+        _ -> Nothing
+      where
+        ma = Just $ 0.5*pi + _rpDir rp + snd (_rmShift rm)
+    closePoints x y = roundPoint2 x == roundPoint2 y
+    getDir (rp:xs) = case _rpLinkStatus rp of
+        UsedInLink {} -> _rpDir rp + snd (_rmShift rm)
+        _ -> getDir xs
+    getDir _ = 0 -- fallback
+
+floorsFromRooms :: [Room] -> [(Point3,Point3)]
+floorsFromRooms = concatMap (concatMap tileToRenderList . getTiles . _rmFloor . doRoomShift)
+
+floorsFromGenWorld :: World -> [(Point3,Point3)]
+floorsFromGenWorld = floorsFromRooms . IM.elems . _genRooms
+
+getTiles :: Floor -> [Tile]
+getTiles fl = case fl of
+    Tiled xs -> xs
+    _ -> error "tiles not correctly set for some room"
+
+--divideWall :: Wall -> [Wall]
+--divideWall wl
+--    = let (a,b) = _wlLine wl
+--          ps = divideLine (zoneSize * 2) a b
+--      in  zipWith (\ x y -> wl & wlLine .~ (x,y) ) (init ps) (tail ps)
+
+--divideWallIn :: Wall -> IM.IntMap Wall -> IM.IntMap Wall
+--divideWallIn wl wls = 
+--    let (wl':newWls) = divideWall wl
+--        k = IM.newKey wls
+--        newWls' = zipWith (\i w -> w {_wlID = i}) [k..] newWls
+--    in  foldl' (flip $ \w -> IM.insert (_wlID w) w) wls (wl':newWls')
+--
+--divideWalls :: IM.IntMap Wall -> IM.IntMap Wall
+--divideWalls wls = foldl' (flip divideWallIn) wls wls
+
+--insertInZone :: Int -> Int -> a -> IM.IntMap (IM.IntMap a) -> IM.IntMap (IM.IntMap a)
+--insertInZone x y obj = IM.insertWith f x $ IM.singleton y obj
+--    where f _ = IM.insert y obj
+
+--shiftRoomTree :: Tree Room -> Tree Room
+--shiftRoomTree (Node t []) = Node t []
+--shiftRoomTree (Node t ts) = Node t 
+--    $ zipWith (\l -> shiftRoomTree . applyToRoot (shiftRoomToLink l)) 
+--    (_rmLinks t) 
+--    ts
+
+--shiftRoomTreeConstruction :: Tree Room -> [Tree Room]
+--shiftRoomTreeConstruction (Node t []) = [Node t []]
+--shiftRoomTreeConstruction (Node t ts) = (Node t [] :) $ concat $
+--    zipWith (\l -> shiftRoomTreeConstruction . applyToRoot (shiftRoomBy l . f)) 
+--    (_rmLinks t) 
+--    ts
+--  where 
+--    f r = shiftRoomBy ( V2 0 0 -.- rotateV (pi-a) p , 0) $ shiftRoomBy (V2 0 0,pi-a)  r
+--      where 
+--        (p,a) = last $ _rmLinks r
+
+--addTile :: Float -> Room -> Room
+--addTile z r
+--    | not (null (_rmFloor r)) || null rp = r
+--    | otherwise = r & rmFloor .~ [makeTileFromPoly poly z]
+--  where
+--    rp = _rmPolys r
+--    poly = orderPolygon . convexHullSafe . nubBy ((==) `on` roundPoint2) $ concat rp

src/Dodge/LevelGen.hs

@@ -24,10 +24,11 @@ import qualified Data.Text.IO as TIO
 generateWorldFromSeed :: Int -> IO World
 generateWorldFromSeed i = do
     createDirectoryIfMissing True "log"
+    createDirectoryIfMissing True "graph"
     writeFile "log/attemptedSeeds" ""
     writeFile "log/treeCluster" ""
     writeFile "log/aGeneratedRoomLayout" ""
-    TIO.writeFile "log/itemCombinations.gv" combinationsDotGraph
+    generateGraphs
     (roomList,bounds) <- layoutLevelFromSeed 0 i
     return $ saveLevelStartSlot 
         $ postGenerationProcessing
@@ -37,6 +38,9 @@ generateWorldFromSeed i = do
 postGenerationProcessing :: World -> World
 postGenerationProcessing w = foldl' assignPushDoors w (_doors w)
 
+generateGraphs :: IO ()
+generateGraphs = TIO.writeFile "graph/itemCombinations.gv" combinationsDotGraph
+
 assignPushDoors :: World -> Door -> World
 assignPushDoors w dr = case dr ^?! drPushedBy of
     PushedBy i -> w & doors . ix i . drPushes ?~ _drID dr

src/Dodge/Path.hs.orig

@@ -0,0 +1,250 @@
+--{-# LANGUAGE TupleSections #-}
+module Dodge.Path 
+    ( pointTowardsImpulse
+    , makePathBetween
+    , makePathBetweenPs
+<<<<<<< HEAD
+    , pairsToGraph
+    , walkableNodeNear
+    , nodesNearL
+    , getNodePos
+    , addObstacleCrossing'
+=======
+--    , removePathsCrossing
+    , obstructPathsCrossing
+    , pairsToGraph
+    , getNodePos
+    , walkableNodeNear
+>>>>>>> efficientRuntime
+    ) where
+import Dodge.Data
+import Dodge.Base.Collide
+import Dodge.Zone
+import Geometry.Data
+import Geometry
+
+import Control.Lens
+import Data.Maybe
+import Data.List
+--import qualified Data.IntMap.Strict as IM
+import Data.Graph.Inductive hiding ((&))
+import Data.Set (Set)
+import qualified Data.Set as Set
+<<<<<<< HEAD
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as M
+=======
+import qualified Data.Map.Strict as M
+import Data.Map.Strict (Map)
+import StreamingHelp
+>>>>>>> efficientRuntime
+import qualified Streaming.Prelude as S
+import StreamingHelp
+--import Data.Graph.Inductive.PatriciaTree
+--import Data.Graph.Inductive.Graph hiding ((&))
+
+getNodePos :: Int -> World -> Maybe Point2
+<<<<<<< HEAD
+getNodePos i w = _pgGraph (_pathGraph w) `lab` i
+
+makePathBetween :: Point2 -> Point2 -> World -> Maybe [Int]
+makePathBetween a b w = do -- join $ sp <$> a' <*> b' <*> return (_pathGraph w)
+    (na,_) <- walkableNodeNear a w
+    (nb,_) <- walkableNodeNear b w
+    sp na nb (second pathDist $ efilter noobstacle $ _pgGraph $ _pathGraph w)
+  where
+    noobstacle (_,_,PathEdge _ _ s) = null s
+
+pathDist :: PathEdge -> Float
+pathDist pe = dist (_peStart pe) (_peEnd pe)
+
+walkableNodeNear :: Point2 -> World -> Maybe (Int,Point2)
+{-# INLINE walkableNodeNear #-}
+walkableNodeNear p w = minStreamOn (dist p . snd) 
+    . S.filter (flip (isWalkable p) w . snd) $ nodesNear p w
+
+nodesNear :: Point2 -> World -> StreamOf (Int,Point2)
+{-# INLINE nodesNear #-}
+nodesNear = aroundPoint _pnZoning
+
+nodesNearL :: Point2 -> World -> [(Int,Point2)]
+nodesNearL p = runIdentity . S.toList_ . nodesNear p
+=======
+getNodePos i w = _pathGraph w `lab` i
+
+makePathBetween :: Point2 -> Point2 -> World -> Maybe [Int]
+makePathBetween a b w = do -- join $ sp <$> a' <*> b' <*> return (_pathGraph w)
+    na <- walkableNodeNear w a
+    nb <- walkableNodeNear w b
+    sp na nb (second _peDist (_pathGraph w))
+  where
+    --nodesNear p = concat $ lookLookups (zoneNearPointIP p) (_pathPoints w)
+--    nodesNear p = runIdentity . S.toList_ $ nearPoint _pnZoning p w
+--    walkableNodeNear p = fmap fst . find (flip (isWalkable p) w . snd) $ nodesNear p
+
+walkableNodeNear :: World -> Point2 -> Maybe Int
+{-# INLINE walkableNodeNear #-}
+walkableNodeNear w p = fmap fst . find (flip (isWalkable p) w . snd) $ nodesNear
+  where
+    --nodesNear = runIdentity . S.toList_ $ nearPoint _pnZoning p w
+    nodesNear = runIdentity . S.toList_ $ aroundPoint _pnZoning p w
+>>>>>>> efficientRuntime
+
+makePathBetweenPs :: Point2 -> Point2 -> World -> Maybe [Point2]
+makePathBetweenPs a b w = mapMaybe (lab $ _pgGraph $ _pathGraph w) <$> makePathBetween a b w
+
+pointTowardsImpulse :: Point2 -> Point2 -> World -> Maybe Point2
+pointTowardsImpulse a b w = find (flip (isWalkable a) w) =<< makePathBetweenPs a b w
+
+------ continues a walk from a list of points, without repetitions
+------ supposes that the list is non-empty
+--randomGraphWalk :: RandomGen g => [Int] -> Gr a b -> State g [Int]
+--randomGraphWalk (n:ns) g = do 
+--    next' <- randomGraphStepRestricted n ns g
+--    case next' of 
+--        Nothing -> return (n:ns)
+--        Just n' -> randomGraphWalk (n':n:ns) g
+--randomGraphWalk _ _ = error "Trying to walk in an empty list"
+--
+--randomPointXStepsFrom :: Int -> Point2 -> World -> Point2
+--randomPointXStepsFrom i p w = 
+--    let g  = _pathGraph w
+--        ns = labNodes g
+--        mp = listToMaybe $ sortBy (compare `on` dist p . snd) $ filter (flip (isWalkable p) w . snd) ns
+--    in case mp of 
+--        Nothing -> p
+--        Just (n,_) -> fromJust 
+--            $ lab g (last $ take i $ randomGraphWalk [n] g Data.Function.& evalState  $ _randGen w)
+--
+--randomPointsXStepsFrom :: Int -> Point2 -> World -> [Point2]
+--randomPointsXStepsFrom i p w = 
+--    let g  = _pathGraph w
+--        ns = labNodes g
+--        mp = listToMaybe $ sortBy (compare `on` dist p . snd) $ filter (flip (isWalkable p) w . snd) ns
+--    in case mp of 
+--        Nothing -> [p]
+--        Just (n,_) -> mapMaybe (lab g) (take i $ randomGraphWalk [n] g Data.Function.& evalState $ _randGen w)
+--
+--randomGraphStep :: RandomGen g => Int -> Gr a b -> State g (Maybe Int)
+--randomGraphStep n g = 
+--    do let ns = neighbors g n
+--       i  <- state $ randomR (0,length ns - 1)
+--       case ns of [] -> return Nothing
+--                  _  -> return $ Just $ ns !! i
+--randomGraphStepRestricted :: RandomGen g => Int -> [Int] -> Gr a b -> State g (Maybe Int)
+--randomGraphStepRestricted n notns g = do 
+--    let ns = neighbors g n \\ notns
+--    i  <- state $ randomR (0,length ns - 1)
+--    case ns of 
+--        [] -> return Nothing
+--        _  -> return $ Just $ ns !! i
+--
+<<<<<<< HEAD
+
+pairsToGraph :: Set.Set (Point2,Point2) -> PathGraph
+pairsToGraph pairset = PathGraph gr' nodemap ncount edgemap
+  where
+    (gr,nodemap,ncount) = insertNodes pairset
+    (gr',edgemap) = insertEdges toPathEdge gr nodemap pairset
+
+toPathEdge :: Point2 -> Point2 -> PathEdge
+toPathEdge sp' ep = PathEdge sp' ep mempty
+
+insertEdges :: (Point2 -> Point2 -> b) 
+    -> Gr Point2 b -> Map Point2 Int 
+    -> Set (Point2,Point2) 
+    -> (Gr Point2 b, Map (V2 Point2) (Int,Int,b))
+insertEdges efunc gr nm = runIdentity . S.fold_ (insertEdge efunc nm) (gr,mempty) id . S.each
+
+insertEdge :: Ord a => (a -> a -> c) -> Map a Int -> (Gr b c,Map (V2 a) (Int,Int,c))
+    -> (a,a)
+    -> (Gr b c,Map (V2 a) (Int,Int,c))
+insertEdge efunc nm (gr',em) (a,b) = (insEdge (f a,f b,efunc a b) gr'
+    , M.insert (V2 a b) (f a,f b,efunc a b) em)
+  where 
+    f x = nm M.! x
+
+insertNodes :: Set (Point2,Point2) -> (Gr Point2 b, Map Point2 Int, Int)
+insertNodes pairset = runIdentity $ S.fold_ insertnode (Data.Graph.Inductive.empty,mempty,0) id nodestream
+  where
+    nodestream :: StreamOf Point2
+    nodestream = S.each . runIdentity $ S.fold_ getnode Set.empty id $ S.each pairset
+    getnode strm (x,y) = Set.insert x $ Set.insert y strm
+    insertnode :: (Gr Point2 b,Map Point2 Int,Int) -> Point2 -> (Gr Point2 b,Map Point2 Int,Int)
+    insertnode (gr,nm,i) n = case M.lookup n nm of
+        Nothing -> (insNode (j,n) gr, M.insert n j nm, j)
+        Just _  -> (gr,nm,i)
+      where
+        j = i + 1
+
+--pairsToGraph :: (Ord a, Ord b) => (a -> a -> b) -> Set.Set (a,a) -> Gr a b
+--pairsToGraph f pairs = undir
+--    $ run_ Data.Graph.Inductive.empty 
+--    $ insMapNodesM (Set.toList nodes') >> insMapEdgesM (Set.toList pairs')
+--  where
+--    nodes' = Set.map fst pairs `Set.union` Set.map snd pairs
+--    pairs' = Set.map (\(x,y)->(x,y,f x y)) pairs
+
+addObstacleCrossing :: World -> EdgeObstacle -> Point2 -> Point2 
+    -> Gr Point2 PathEdge
+    -> Gr Point2 PathEdge
+addObstacleCrossing w eo a b gr = runIdentity $ S.fold_ updateedge gr id paths
+  where
+    updateedge gr' (xi,yi,PathEdge x y obs) = insEdge (xi,yi,PathEdge x y (Set.insert eo obs))
+        $ delEdge (xi,yi) gr'
+    paths = S.filter f $ nearSeg _peZoning a b w
+    f (_,_,PathEdge x y _) = isJust $ intersectSegSeg x y a b
+
+addObstacleCrossing' :: EdgeObstacle -> Point2 -> Point2 
+    -> World
+    -> World
+addObstacleCrossing' eo a b w = w & pathGraph . pgGraph %~ addObstacleCrossing w eo a b
+=======
+pairsToGraph :: Set.Set (Point2,Point2) -> (Map (V2 Point2) (Int,Int,PathEdge),Gr Point2 PathEdge)
+pairsToGraph pairs = addEdges nodemap gr $ S.each pairs
+  where
+    (nodemap,_,gr) = addNodes $ S.map fst (S.each pairs) <> S.map snd (S.each pairs)
+--    let nodes' = Set.map fst pairs `Set.union` Set.map snd pairs
+--        pairs' = Set.map (\(x,y)->(x,y,f x y)) pairs
+--    in undir $ run_ Data.Graph.Inductive.empty $ insMapNodesM (Set.toList nodes') >> insMapEdgesM (Set.toList pairs')
+
+addNodes :: StreamOf Point2 -> (Map Point2 Int,Int,Gr Point2 PathEdge)
+addNodes = runIdentity . S.fold_ f (mempty,0,Data.Graph.Inductive.empty) id
+  where
+    f (nodemap,i,gr) p = case nodemap M.!? p of
+        Just _  -> (nodemap,i,gr)
+        Nothing -> (nodemap & at p ?~i ,i+1, insNode (i,p) gr)
+addEdges :: Map Point2 Int -> Gr Point2 PathEdge -> StreamOf (Point2,Point2) 
+    -> (Map (V2 Point2) (Int,Int,PathEdge) , Gr Point2 PathEdge)
+addEdges nodemap gr = runIdentity . S.fold_ f (mempty,gr) id
+  where
+    f (edgemap,gr') (a,b) = (M.insert (V2 a b) theedge edgemap
+        , insEdge theedge gr'
+        )
+      where
+        theedge = (g a,g b,PathEdge a b (dist a b) mempty)
+    g a = nodemap M.! a
+
+obstructPathsCrossing :: Point2 -> Point2 -> World -> ( World, [(Int,Int,PathEdge)])
+obstructPathsCrossing sp ep w = 
+    ( w & pathGraph %~ updateedges
+    , runIdentity $ S.toList_ edges
+    )
+  where
+    edges = S.filter edgecrosses $ nearSeg _peZoning sp ep w
+    edgecrosses (_,_,pe) = isJust $ intersectSegSeg sp ep (_peStart pe) (_peEnd pe)
+    updateedges gr = runIdentity $ S.fold_ updateedge gr id edges
+    updateedge gr (x,y,pe) 
+        = insEdge (x,y,pe & peObstacles . at BlockObstacle .~ Just ()) $ delEdge (x,y) gr
+
+removePathsCrossing :: Point2 -> Point2 -> World -> World
+removePathsCrossing a b w = w
+--    & pathGraph  .~ newGraph 
+--    & pathGraphP .~ pg'
+--    & phZoning   %~ \zn -> foldl' (flip $ updateZoning (:)) (zn & znObjects .~ mempty)
+--        (labNodes newGraph)
+--  where 
+--    pg' = Set.filter (isNothing . uncurry (intersectSegSeg a b)) $ _pathGraphP w
+--   -- insertPoint pp@(_,p) = insertInZoneWith (wlZoneOfPoint p) (++) [pp]
+--    newGraph = pairsToGraph pg'
+>>>>>>> efficientRuntime

src/Dodge/Placement/PlaceSpot.hs.orig

@@ -0,0 +1,203 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE RankNTypes #-}
+-- | 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 Dodge.Placement.Shift
+import Dodge.Data
+import Dodge.Path
+import Dodge.Placement.PlaceSpot.Block
+import Dodge.Placement.PlaceSpot.TriggerDoor
+import Dodge.Default.Wall
+import Dodge.ShiftPoint
+import Dodge.Base.NewID
+import Geometry
+import qualified IntMapHelp as IM
+import Color
+
+import Data.Foldable
+import Data.Maybe
+import System.Random
+import Control.Monad.State
+import Control.Lens
+import qualified Data.IntSet as IS
+import Data.Bifunctor
+
+-- when placing a placement, we update the world and the room and assign an id
+-- to the placement
+placeSpot :: (World,Room) -> Placement -> ( (World,Room), [Placement] )
+placeSpot (w,rm) plmnt = case plmnt of
+    Placement{_plSpot = PSRoomRand i f} -> placeSpotRoomRand rm i f plmnt w
+    Placement{_plSpot = PSPos extract eff fallback} -> placeSpotUsingLink w rm plmnt extract eff fallback
+    Placement{} -> placePlainPSSpot w rm plmnt shift
+    PlacementUsingPos p subpl -> placeSpot (w,rm) (subpl (shiftPoint3By shift p))
+    RandomPlacement rplmnt -> placeRandomPlacement rplmnt w rm
+    PickOnePlacement i pl -> ((placePickOne i pl rm w, rm), [])
+  where
+    shift = _rmShift rm
+
+placePickOne :: Int -> Placement -> Room -> World -> World
+placePickOne i pl rm w = w & genPlacements %~ IM.insertWith (++) i [(pl, fromJust (_rmMID rm))]
+
+placeRandomPlacement :: State StdGen Placement -> World -> Room -> ((World,Room),[Placement])
+placeRandomPlacement rplmnt w rm = placeSpot (w & randGen .~ g,rm) plmnt'
+  where
+    (plmnt', g) = runState rplmnt (_randGen w)
+
+placePlainPSSpot :: World -> Room -> Placement -> DPoint2 -> ((World,Room),[Placement])
+placePlainPSSpot w rm plmnt shift = 
+    let (i,w') = placeSpotID (shiftPSBy shift (_plSpot plmnt)) (_plType plmnt) w
+        newplmnt = plmnt & plMID ?~ i
+    in maybe ((w',rm),[newplmnt]) (recrPlace newplmnt w') (_plIDCont plmnt w' newplmnt)
+  where
+    recrPlace newplmnt w' pl = let (wr,newplmnts) = placeSpot (w',rm) pl
+                    in (wr,newplmnt:newplmnts)
+
+-- this should be tidied up
+placeSpotUsingLink :: World 
+    -> Room 
+    -> Placement 
+    -> (RoomPos -> Room -> Maybe (PlacementSpot,RoomPos))
+    -> (RoomPos -> Room -> Room)
+    -> Maybe Placement
+    -> ((World, Room), [Placement])
+placeSpotUsingLink w rm plmnt extract eff fallback = case searchedPoss (_rmPos rm) of
+    Just (ps,rmposs) -> placeSpot (w, eff (head rmposs) $ rm & rmPos .~ rmposs) (plmnt & plSpot .~ ps)
+    Nothing -> case fallback of
+        Nothing -> ((w,rm),[plmnt])
+        Just plmnt' -> placeSpot (w,rm) plmnt'
+  where
+    searchedPoss [] = Nothing
+    searchedPoss (pos:poss) = case extract pos rm of
+        Nothing -> second (pos:) <$> searchedPoss poss
+        Just (ps,rmpos) -> Just ( ps,rmpos:poss)
+
+placeSpotRoomRand :: Room -> Int -> (DPoint2 -> PlacementSpot) 
+    -> Placement -> World -> ((World,Room),[Placement])
+placeSpotRoomRand rm i f plmnt w =
+    let (ps,g) = runState (_rmRandPSs rm !! i) $_randGen w
+    in placeSpot (w & randGen .~ g,rm) (plmnt & plSpot .~ f ps)
+
+-- the Int here is some id that is assigned when the placement is placed
+placeSpotID :: PlacementSpot -> PSType -> World -> (Int, World)
+placeSpotID ps pt w = case pt of
+    PutTrigger  cnd         -> plNewID   triggers cnd w
+    PutMod      mdi         -> plNewUpID modifications mdID mdi w
+    PutProp     prp         -> plNewUpID props pjID (mvProp p rot prp) w
+    PutButton   bt          -> plNewUpID buttons btID (mvButton p rot bt) w
+    PutTerminal tm          -> plNewUpID terminals tmID tm w
+    PutFlIt     itm         -> plNewUpID floorItems flItID (createFlIt p rot itm) w
+    PutCrit     cr          -> plNewUpID creatures crID (mvCr p rot cr) w
+    PutForeground fs        -> plNewUpID shapes fsID (mvFS p rot fs) w
+    PutMachine  pps mc      -> plMachine (map doShift pps) mc p rot w
+    PutLS       ls          -> plNewUpID lightSources lsID (mvLS p' rot ls) w
+    PutPPlate   pp          -> plNewUpID pressPlates ppID (mvPP p rot pp) w
+    RandPS      rgn         -> evaluateRandPS rgn ps w
+    PutDoor     col f   pss -> plDoor col f (map (bimap doShift doShift) pss) w
+    PutCoord    cp          -> plNewID   coordinates (doShift cp) w
+    PutSlideDr  wl dr off  a   b 
+                            -> plSlideDoor wl dr off (doShift a) (doShift b) w
+    PutBlock    bl wl  ps'  -> plBlock (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,placeWallPoly (map doShift qs) wl w)
+    PutNothing              -> (0,w)
+    PutID i                 -> (i, w)
+    PutWorldUpdate f        -> (0, w & f ps)
+    PutUsingGenParams f     ->  let (w',pt') = f w
+                                in placeSpotID ps pt' w'
+  where 
+    p@(V2 px py) = _psPos ps
+    p' = V3 px py 0
+    rot = _psRot ps
+    doShift = shiftPointBy (p,rot)
+
+evaluateRandPS :: State StdGen PSType -> PlacementSpot -> World -> (Int,World)
+evaluateRandPS rgen ps w = placeSpotID ps evaluatedType (set randGen g w)
+  where 
+    (evaluatedType, g) = runState rgen (_randGen w)
+
+placeWallPoly :: [Point2] -> Wall -> World -> World
+<<<<<<< HEAD
+--placeWallPoly ps wl = over walls (placeWalls ps wl)
+placeWallPoly ps wl = rmCrossPaths . over walls (placeWalls ps wl)
+  where
+    rmCrossPaths w = foldr (uncurry (addObstacleCrossing' WallObstacle)) w $ loopPairs ps
+=======
+placeWallPoly ps wl = -- rmCrossPaths . 
+    over walls (placeWalls ps wl)
+--  where
+--    rmCrossPaths w = foldr (uncurry obstructPathsCrossing) w $ loopPairs ps
+>>>>>>> efficientRuntime
+
+placeWalls :: [Point2] -> Wall -> IM.IntMap Wall -> IM.IntMap Wall
+placeWalls qs wl wls = foldl' (addPane wl) wls pairs
+  where 
+    (p:ps) = orderPolygon qs
+    pairs = zip (ps ++ [p]) (p:ps)
+
+addPane :: Wall -> IM.IntMap Wall -> (Point2,Point2) -> IM.IntMap Wall
+addPane wl wls l = IM.insert wlid (wl { _wlLine = l, _wlID = wlid }) wls
+  where
+    wlid = IM.newKey wls
+
+---- | place an new object into an intmap and update its id
+--plNewUpID :: ALens' World (IM.IntMap a)
+--    -> ALens' a Int
+--    -> a
+--    -> World
+--    -> (Int,World)
+--plNewUpID l li x w = (i,w & l #%~ IM.insert i (x & li #~ i))
+--  where
+--    i = IM.newKey $ w ^# l
+
+mvProp :: Point2 -> Float -> Prop -> Prop
+mvProp p a = (pjRot +~ a) . (prPos %~ ( (p +.+) . rotateV a ))
+
+mvButton :: Point2 -> Float -> Button -> Button
+mvButton p a = (btRot +~ a) . (btPos %~ ( (p +.+) . rotateV a ))
+
+{- Creates a floor item at a given point.-}
+createFlIt :: Point2 -> Float -> Item -> FloorItem
+createFlIt p rot itm = FlIt { _flItPos = p , _flItRot = rot , _flItID = 0 , _flIt = itm }
+
+mvPP :: Point2 -> Float -> PressPlate -> PressPlate
+mvPP p rot pp = pp {_ppPos = p,_ppRot = rot}
+
+mvCr :: Point2 -> Float -> Creature -> Creature
+mvCr p rot cr = cr {_crPos = p,_crOldPos = p,_crDir = rot}
+
+mvFS :: Point2 -> Float -> ForegroundShape -> ForegroundShape
+mvFS p a = (fsDir +~ a) . (fsPos %~ ( (p +.+) . rotateV a ))
+
+plMachine :: [Point2] -> Machine -> Point2 -> Float -> World -> (Int,World)
+plMachine wallpoly mc p rot gw = (mcid
+    , gw & machines  %~ addMc
+         & walls     %~ placeMachineWalls color wallpoly mcid wlid
+    )
+  where 
+    color = _mcColor mc
+    w' = gw
+    mcid = IM.newKey $ _machines w'
+    wlid = IM.newKey $ _walls w'
+    wlids = IS.fromList [wlid .. wlid + length wallpoly - 1]
+    --addMc = IM.insert mcid (mc {_mcPos = centroid wallpoly,_mcDir = rot,_mcID = mcid, _mcWallIDs = wlids})
+    addMc = IM.insert mcid (mc {_mcPos = p,_mcDir = rot,_mcID = mcid, _mcWallIDs = wlids})
+
+-- TODO correctly remove/shift pathfinding lines (removePathsCrossing)
+placeMachineWalls :: Color -> [Point2] -> Int -> Int -> IM.IntMap Wall -> IM.IntMap Wall
+placeMachineWalls col poly mcid wlid = flip (foldr f) $ zip [wlid..] $ loopPairs poly
+  where
+    f (wid,l) = IM.insert wid baseWall{_wlID = wid, _wlLine = l}
+    baseWall = defaultMachineWall 
+        & wlColor .~ col
+        & wlStructure . wsMachine .~ mcid
+        & wlTouchThrough .~ True
+
+mvLS :: Point3 -> Float -> LightSource -> LightSource
+mvLS (V3 x y z) rot ls = ls & lsParam . lsPos .~ V3 x y z +.+.+ startPos
+    & lsDir .~ rot
+  where
+    startPos = onXY (rotateV rot) $ _lsPos (_lsParam ls)

src/Dodge/Placement/PlaceSpot/Block.hs.orig

@@ -0,0 +1,126 @@
+{- | Creation, update and destruction of destructible walls.  -}
+module Dodge.Placement.PlaceSpot.Block 
+    ( plBlock
+    , plLineBlock
+    )
+    where
+import Dodge.Data
+import Dodge.Path
+import Dodge.Block.Debris
+--import Dodge.LevelGen.LevelStructure
+import Dodge.Base
+--import Dodge.Zone
+import Geometry
+import qualified IntMapHelp as IM
+
+import Control.Lens
+import qualified Data.IntSet as IS
+
+plBlock 
+    :: [Point2]     -- ^ Block polygon
+    -> Block
+    -> Wall         -- ^ Base Pane
+    -> World 
+    -> (Int,World)
+plBlock [] _ _ _ = error "Trying to add a block with incomplete polygon"
+plBlock (p:ps) bl wl w = (,) blid $ w
+<<<<<<< HEAD
+    & flip (foldr insertWall) wls
+=======
+>>>>>>> efficientRuntime
+    & blocks . at blid ?~ bl 
+        { _blID = blid
+        , _blWallIDs = IS.fromList is
+        , _blShadows = []
+        , _blFootprint = p:ps
+        }
+<<<<<<< HEAD
+=======
+    & insertWalls blid wls
+>>>>>>> efficientRuntime
+  where 
+    blid = IM.newKey $ _blocks w
+    lns = zip (p:ps) (ps ++ [p])
+    i = IM.newKey $ _walls w
+    is = [i.. i + length lns-1]
+    wls = zipWith 
+        (\j ln -> wl & wlLine .~ ln & wlID .~ j & wlStructure .~ BlockPart blid) 
+        is 
+        lns 
+        
+{- | Splits a line into many four cornered blocks. -}
+plLineBlock 
+    :: Wall     -- ^ Base pane
+    -> Float
+    -> Point2   -- ^ Start point (symmetric)
+    -> Point2   -- ^ End point (symmetric)
+    -> World 
+    -> (Int, World)
+plLineBlock basePane blwidth a b gw = ( 0 
+<<<<<<< HEAD
+    , foldr insertWall (insertBlocks gw) listWalls
+=======
+--    , foldr insertWall (insertBlocks gw) listWalls
+    , insertBlocks gw
+>>>>>>> efficientRuntime
+    )
+  where 
+    depth = blwidth
+    psOnLine = divideLineOddNumPoints blwidth a b
+    halfBlockWidth = dist a b / fromIntegral (length psOnLine - 1)
+    blockCenPs = snd $ evenOddSplit psOnLine
+    numBlocks = length blockCenPs
+    is = [0.. numBlocks - 1]
+    cornerPoints = reverse $ rectWH halfBlockWidth depth -- goes clockwise around the block
+    cornersAt p = fmap ( (p +.+) . rotateV (argV (b -.- a)) ) cornerPoints
+    linesAt p = loopPairs $ cornersAt p
+    wlid = IM.newKey $ _walls gw
+    blid = IM.newKey $ _blocks gw
+    insertBlock (i,p) = 
+        insertWalls (i + blid) (makeWallAt p i)
+        . (over blocks $ IM.insert (i+blid) Block 
+        { _blID = i + blid, _blWallIDs = IS.fromList $ ksAtI i
+        , _blHP = 1000, _blShadows = shadowsAt i
+        , _blDir = 0    -- THIS IS NOT SENSIBLE. TODO rethink block positioning
+        , _blFootprint = cornersAt p -- TODO check winding (clockwise, anticlockwise)
+        , _blObstructs = []
+<<<<<<< HEAD
+=======
+        , _blPaths = []
+>>>>>>> efficientRuntime
+        , _blPos = p, _blDraw = const mempty , _blDeath = makeBlockDebris}
+        )
+    insertBlocks = flip (foldr insertBlock) $ zip is blockCenPs
+    ksAtI i = map ( + (wlid + i*4) ) [0,1,2,3]
+    visibilityAt i 
+        | i == 0             = [False,True,True ,True]
+        | i == numBlocks - 1 = [True ,True,False,True]
+        | otherwise          = [False,True,False,True]
+    shadowsAt i
+        | i == 0             = ksAtI 1
+        | i == numBlocks - 1 = ksAtI $ numBlocks - 2
+        | otherwise          = ksAtI (i-1) ++ ksAtI (i+1)
+    makeWallAt p i = zipWith3 (makePane i) (visibilityAt i) (ksAtI i) (linesAt p)
+    makePane i visStatus k ps = basePane
+        {_wlID = k
+        ,_wlStructure = BlockPart $ i + blid
+        ,_wlLine = ps
+        ,_wlDraw = visStatus
+        }
+    listWalls = concat $ zipWith makeWallAt blockCenPs is
+
+<<<<<<< HEAD
+insertWall :: Wall -> World -> World
+insertWall wl = (walls . at (_wlID wl) ?~ wl)
+    . uncurry (addObstacleCrossing' BlockObstacle) (_wlLine wl)
+=======
+-- | Must be done after inserting the block
+insertWalls :: Int -> [Wall] -> World -> World
+insertWalls blid wls w = w' & blocks . ix blid . blPaths .~ concat paths
+  where
+    (w',paths) = mapAccumR (flip insertWall) w wls
+
+insertWall :: Wall -> World -> (World,[(Int,Int,PathEdge)])
+insertWall wl = uncurry obstructPathsCrossing (_wlLine wl)
+    . (walls . at (_wlID wl) ?~ wl)
+>>>>>>> efficientRuntime

src/Dodge/Placement/Random.hs

@@ -8,6 +8,6 @@ randFirstWeapon :: State StdGen Item
 randFirstWeapon = takeOne $
     replicate 10 pistol
     ++ replicate 5 (bangStick 4)
-    ++ replicate 5 (bangCaneX 3)
+    ++ replicate 5 (volleyGun 3)
     ++ replicate 5 bangCone
     ++ [lasGun]

src/Dodge/Render/ShapePicture.hs.orig

@@ -0,0 +1,392 @@
+module Dodge.Render.ShapePicture
+    ( worldSPic
+    ) where
+import Dodge.Creature.Picture.Awareness
+import Dodge.ShortShow
+import Dodge.Config.Data
+import Dodge.Render.InfoBox
+import Dodge.Debug.Picture
+import Dodge.Picture.SizeInvariant
+import Dodge.Data
+import Dodge.Zone
+import Dodge.Base
+--import Dodge.Base.Window
+import Dodge.SoundLogic.LoadSound
+import Dodge.Graph
+import Dodge.GameRoom
+import Dodge.Update.Camera
+import Dodge.Item.Draw
+import Dodge.Render.List
+import Dodge.Path
+--import Dodge.Zone
+import Geometry
+import Geometry.Zone
+import ShapePicture
+import Picture
+import Sound.Data
+import Geometry.ConvexPoly
+--import Dodge.Base.Collide
+
+--import Data.Foldable
+import qualified Data.IntMap.Strict as IM -- Lazy?
+import qualified Data.Map.Strict as M
+--import qualified Data.Set as Set
+import Control.Lens
+import Data.Maybe
+import qualified Streaming.Prelude as S
+import qualified Data.Graph.Inductive as FGL
+import qualified Data.Set as Set
+
+-- TODO only filter out shapes outside the range of the furthest shown light source
+worldSPic :: Configuration -> World -> SPic
+worldSPic cfig w = (mempty, extraPics cfig w)
+    <> foldMap (dbArg _prDraw) (filtOn _prPos _props)
+    <> foldMap (shiftDraw _blPos _blDir _blDraw) (filtOn _blPos _blocks)
+    <> foldMap (shiftDraw _fsPos _fsDir (const _fsSPic)) (filtOn _fsPos _shapes)
+    <> foldMap (dbArg _cpPict) (filtOn _cpPos _corpses)
+    <> foldMap (dbArg _crPict) (filtOn _crPos _creatures)
+    <> foldMap floorItemSPic (filtOn _flItPos _floorItems)
+    <> foldMap btSPic (filtOn _btPos _buttons)
+    <> foldMap mcSPic (filtOn _mcPos _machines)
+    <> anyTargeting cfig w
+  where
+    filtOn f g = IM.filter (pointIsClose . f) (g w)
+    pointIsClose = cullPoint cfig w
+
+anyTargeting :: Configuration -> World -> SPic
+anyTargeting cfig w = (mempty,pictures $ IM.elems $ IM.mapMaybe f $ _crInv cr)
+  where
+    cr = you w
+    f it = fmap (\g -> g it cr cfig w) (it ^? itTargeting . tgDraw)
+
+shiftDraw :: (a -> Point2) -> (a -> Float) -> (a -> a -> SPic) -> a -> SPic
+shiftDraw fpos fdir fdraw x = uncurryV translateSPf (fpos x)
+    . rotateSP (fdir x)
+    $ fdraw x x
+
+cullPoint :: Configuration -> World -> Point2 -> Bool
+cullPoint cfig w p 
+    | debugOn Close_shape_culling cfig = pointInPolygon p (_boundBox w)
+    | otherwise = dist (_cameraCenter w) p < _viewDistance w
+
+-- TODO filter out pictures not in the frame
+extraPics :: Configuration -> World -> Picture
+extraPics cfig w = pictures (_decorations w)
+    <> concatMapPic (dbArg _ptDraw) (_particles    w)
+    <> concatMapPic (dbArg _bmDraw) (_positronBeams $ _beams w)
+    <> concatMapPic (dbArg _bmDraw) (_electronBeams $ _beams w)
+    <> concatMapPic (dbArg _lsPict) (_lightSources w)
+    <> testPic cfig w
+    <> _debugPicture w
+--    <> runIdentity (S.foldMap_ clDraw (_clouds w))
+    <> concatMapPic clDraw (_clouds w      )
+    <> concatMapPic ppDraw (_pressPlates w )
+    <> viewClipBounds cfig w
+<<<<<<< HEAD
+    <> debugDraw cfig w
+=======
+--    <> debugDraw cfig w
+>>>>>>> efficientRuntime
+
+debugDraw :: Configuration -> World -> Picture
+debugDraw cfig w = pic
+    <> setLayer FixedCoordLayer (listPicturesAt (0.5*halfWidth cfig) 0 cfig $ map text ts)
+  where
+    (ts, pic) = foldMap (f . debugDraw' cfig w) (_debug_booleans cfig)
+    f (Left s) = ([s],mempty)
+    f (Right pic') = (mempty,pic')
+
+debugDraw' :: Configuration -> World -> DebugBool -> Either String Picture
+debugDraw' cfig w bl = case bl of
+    Noclip      -> Left "Noclip"
+    Remove_LOS  -> Left "No line of sight"
+    Cull_more_lights    -> Left "Cull more lights"
+    Close_shape_culling -> Left "Close shape culling"
+    Bound_box_screen    -> Left "bound box screen, this should be moved"
+    Show_ms_frame           -> Right mempty
+    View_boundaries         -> Right $ viewBoundaries w
+    Show_bound_box          -> Right $ drawBoundingBox w
+    Show_wall_search_rays   -> Right $ drawWallSearchRays w
+    Show_dda_test           -> Right $ drawDDATest w
+    Show_far_wall_detect    -> Right $ drawFarWallDetect w
+    Show_select             -> Right $ drawWorldSelect w
+    Inspect_wall            -> Right $ drawInspectWalls w
+    Cr_awareness            -> Right $ drawCreatureDisplayTexts w
+    Show_sound              -> Right $ pictures $ M.map (soundPic cfig w) $ _playingSounds w
+    Cr_status               -> Right $ drawCrInfo cfig w
+    Mouse_position          -> Right $ drawMousePosition cfig w
+    Walls_info              -> Right $ drawWlIDs cfig w
+    Pathing                 -> Right $ drawPathing cfig w
+    Show_nodes_near_select  -> Right $ drawNodesNearSelect w
+    Show_path_between       -> Right $ drawPathBetween w
+
+drawCreatureDisplayTexts :: World -> Picture
+drawCreatureDisplayTexts w = foldMap (creatureDisplayText w) (_creatures w)
+
+drawPathBetween :: World -> Picture
+drawPathBetween w = setLayer DebugLayer
+    $  color yellow (foldMap (arrowPath . mapMaybe nodepos) nodelist)
+<<<<<<< HEAD
+    <> foldMap (color green . arrow sp) (nodepos =<< nodelist ^? _Just . ix 0)
+    <> foldMap (color cyan . flip arrow ep) (nodepos =<< lastOf traverse =<< nodelist ^? _Just)
+=======
+    <> foldMap (color green . arrow sp) (nodepos =<< walkableNodeNear w sp)
+    <> foldMap (color cyan . flip arrow ep) (nodepos =<< walkableNodeNear w ep)
+>>>>>>> efficientRuntime
+  where
+    nodepos = (`getNodePos` w)
+    nodelist = makePathBetween sp ep w
+    sp = _lSelect w
+    ep = _rSelect w
+
+drawNodesNearSelect :: World -> Picture
+drawNodesNearSelect w = setLayer DebugLayer $
+     runIdentity (S.foldMap_ (drawZone pnZoneSize) (zoneAroundPoint pnZoneSize sp))
+<<<<<<< HEAD
+    <> color red (foldMap (drawCross . snd) $ nodesNearL sp w)
+    <> color green (drawCross sp)
+    <> color cyan (foldMap (drawCross . snd) $ walkableNodeNear sp w)
+=======
+--    <> color red (foldMap (drawCross . snd) $ nodesNearL sp w)
+    <> color green (drawCross sp)
+--    <> color cyan (foldMap (drawCross . snd) $ walkableNodeNear sp w)
+>>>>>>> efficientRuntime
+  where
+    sp = _lSelect w
+
+drawInspectWalls :: World -> Picture
+drawInspectWalls w = foldMap (drawInspectWall w) 
+    $ filter (isJust . uncurry (intersectSegSeg a b) . _wlLine)
+    $ IM.elems $ _walls w
+  where
+    (a,b) = _lLine w
+
+drawInspectWall :: World -> Wall -> Picture
+drawInspectWall _ wl = setLayer DebugLayer $ 
+        color rose (thickLine 3 [a,b])
+    <> foldMap (drawZone wlZoneSize)
+        (runIdentity $ S.toList_ $ zoneOfWall wlZoneSize wl)  -- this won't work if wlZoneSize is not consistent
+  where
+    (a,b) = _wlLine wl 
+--    $ line [a,b]
+--  where
+--    (a,b) = _wSelect w
+
+drawWorldSelect :: World -> Picture
+drawWorldSelect w = setLayer DebugLayer
+    $  color cyan (line [a,b])
+    <> color magenta (line [c,d])
+  where
+    (a,b) = _lLine w
+    (c,d) = _rLine w
+
+drawFarWallDetect :: World -> Picture
+drawFarWallDetect w = setLayer DebugLayer 
+    . color yellow 
+    . concatMap (\q -> line 
+        [ p
+        , fst $ collidePoint p q $ S.filter wlIsOpaque $ wlsNearSeg p q w
+        ]   )
+    $ runIdentity $ S.toList_ $ streamViewpoints p w
+  where
+    p = _cameraViewFrom w
+
+drawDDATest :: World -> Picture
+drawDDATest w = runIdentity (S.foldMap_ (drawZone 50) ps)
+    <> runIdentity (S.foldMap_ (drawZone' 50) ps')
+    <> runIdentity (S.foldMap_ drawCross qs)
+    <> color blue (runIdentity (S.foldMap_ drawCross qs'))
+    <> setLayer DebugLayer (color yellow (line [cvf,mwp]))
+  where
+    cvf = _cameraViewFrom w
+    mwp = mouseWorldPos w
+    ps = ddaStreamX 50 cvf mwp
+    ps' = ddaStreamY 50 (_cameraViewFrom w) (mouseWorldPos w)
+    qs = xIntercepts 50 (_cameraViewFrom w) (mouseWorldPos w)
+    qs' = yIntercepts 50 (_cameraViewFrom w) (mouseWorldPos w)
+
+drawCross :: Point2 -> Picture
+drawCross p = setLayer DebugLayer . color red . uncurryV translate p $ crossPic 5
+
+crossPic :: Float -> Picture
+crossPic x = line [V2 x x,V2 (-x) (-x)] <> line [V2 (-x) x,V2 x (-x)]
+
+drawZone :: Float -> V2 Int -> Picture
+drawZone s (V2 x y) = setLayer DebugLayer . color orange $ thickLine 2 (p:ps ++ [p])
+  where
+    (p:ps) = zipWith (+.+) innerSquare $ map ((s*.*) . (each %~ fromIntegral)) [V2 x y, V2 (x+1) y, V2 (x+1) (y+1), V2 x (y+1)]
+
+drawZone' :: Float -> V2 Int -> Picture
+drawZone' s (V2 x y) = setLayer DebugLayer . color green $ line (p:ps ++ [p])
+  where
+    (p:ps) = zipWith (+.+) (map (2*.*) innerSquare) $ map ((s*.*) . (each %~ fromIntegral)) [V2 x y, V2 (x+1) y, V2 (x+1) (y+1), V2 x (y+1)]
+
+innerSquare :: [Point2]
+innerSquare = [V2 1 1, V2 (-1) 1, V2 (-1) (-1), V2 1 (-1)]
+
+drawWallSearchRays :: World -> Picture
+drawWallSearchRays w = runIdentity $ S.foldMap_ f $ S.map fst $ allVisibleWalls w
+  where
+    f p = setLayer DebugLayer $ color yellow $ uncurryV translate p (circle 5)
+        <> line [_cameraViewFrom w, p]
+
+testPic :: Configuration -> World -> Picture
+testPic _ _ = mempty
+
+drawBoundingBox :: World -> Picture
+drawBoundingBox w = setLayer DebugLayer $ color green $ line $ (x:xs) ++ [x]
+  where
+    (x:xs) = _boundBox w
+
+clDraw :: Cloud -> Picture
+clDraw c = translate3 (_clPos c) (_clPict c c)
+ppDraw :: PressPlate -> Picture
+ppDraw c = uncurryV translate (_ppPos c) $ rotate (_ppRot c) (_ppPict c)
+
+floorItemSPic :: FloorItem -> SPic
+floorItemSPic flit = uncurryV translateSPf (_flItPos flit) 
+    $ rotateSP (_flItRot flit)  (itSPic (_flIt flit))
+
+btSPic :: Button -> SPic
+btSPic bt = uncurryV translateSPf (_btPos bt)
+    $ rotateSP (_btRot bt) (_btPict bt bt)
+mcSPic :: Machine -> SPic
+mcSPic bt = uncurryV translateSPf (_mcPos bt)
+    $ rotateSP (_mcDir bt) (_mcDraw bt bt)
+
+soundPic :: Configuration -> World -> Sound -> Picture
+soundPic cfig w s = fixedSizePicClampArrow 50 50 thePic p cfig w
+  where
+    p = _soundPos s
+    thePic 
+        = rotate (_cameraRot w) 
+        . scale theScale theScale 
+        . centerText 
+        . soundToOnomato 
+        $ _soundChunkID s
+    theScale = 0.15 * f (_soundVolume s * 0.0001)
+    f x = 1 - 0.5 * (1 - x)
+
+drawMousePosition :: Configuration -> World -> Picture
+drawMousePosition cfig w = setLayer FixedCoordLayer . winScale cfig
+    . uncurryV translate p
+    . scale 0.1 0.1
+    . text 
+    $ shortPoint2 mwp 
+  where
+    p = worldPosToScreen w mwp
+    mwp = mouseWorldPos w
+
+drawWlIDs :: Configuration -> World -> Picture
+drawWlIDs cfig w = setLayer FixedCoordLayer $ foldMap f (_walls w)
+  where
+    f wl 
+        | dist (_crPos $ you w) (fst (_wlLine wl)) > 200 = mempty  -- this should be improved with a better "on screen test"
+        | otherwise = winScale cfig
+            . uncurryV translate p
+            . scale 0.1 0.1
+            . text 
+            $ show $ _wlID wl 
+      where
+        p = worldPosToScreen w $ 0.5 *.* uncurry (+.+) (_wlLine wl)
+
+edgeToPic :: [Point2] -> PathEdge -> Picture
+edgeToPic poly pe
+    | not (pointInPolygon sp poly) && not (pointInPolygon ep poly) = mempty
+    | null $ _peObstacles pe 
+                = anarrow green
+    | hasobstacle BlockObstacle  
+                = anarrow red
+    | hasobstacle AutoDoorObstacle = anarrow yellow
+    | otherwise = anarrow cyan
+  where
+    hasobstacle = (`Set.member` _peObstacles pe)
+    anarrow col = color col $ arrow sp ep
+    sp = _peStart pe
+    ep = _peEnd pe
+
+drawPathing :: Configuration -> World -> Picture
+drawPathing cfig w = setLayer DebugLayer
+    $  foldMap (edgeToPic (screenPolygon cfig w) . (^?! _3)) (FGL.labEdges gr)
+    <> concatMap dispInc (graphToIncidence gr)
+  where
+    dispInc (p,n) = setDepth 2 . uncurryV translate p . scale 0.1 0.1 $ text $ show n
+    gr = _pgGraph $ _pathGraph w
+
+crDisplayInfo :: Configuration -> World -> Creature -> Maybe (Point2,[String])
+crDisplayInfo cfig w cr 
+--    | _crID cr == 0 = Nothing
+    | crOnScreen = Just (_crPos cr, catMaybes
+--        [fmap show $ ap ^? crGoal
+        [ fmap show $ cr ^? crHP
+        , fmap show $ ap ^? crStrategy
+        , fmap show $ cr ^? crPos
+        , fmap show $ cr ^? crPerception . cpVigilance
+--        , fmap show $ cr ^? crOldPos
+        , fmap show $ ap ^? crAction
+        , fmap show $ ap ^? crImpulse
+        ]
+        )
+    | otherwise = Nothing
+  where
+    ap = _crActionPlan cr
+    crOnScreen = pointOnScreen cfig w $ _crPos cr
+
+drawCrInfo :: Configuration -> World -> Picture
+drawCrInfo cfig w = setLayer FixedCoordLayer 
+        $ renderInfoListsAt (2*hw - 400) 0 cfig w
+        $ mapMaybe (crDisplayInfo cfig w) $ IM.elems $ _creatures w
+  where
+    hw = halfWidth cfig
+
+viewBoundaries :: World -> Picture
+viewBoundaries w = setLayer DebugLayer $ color green (concatMap (polygonWire . _grBound) grs)
+    <> color yellow (concatMap (\q -> line [p,q]) $ farWallPoints p w)
+  where
+    p = _crPos $ you w
+    grs = filter (pointInOrOnPolygon p . _grBound) (_gameRooms w)
+
+viewClipBounds :: Configuration -> World -> Picture
+viewClipBounds cfig w
+    | _debug_view_clip_bounds cfig == AllRoomClipBoundaries
+         = setLayer DebugLayer $ color green $ concatMap (polygonWire . _cpPoints) (_roomClipping w)
+    | _debug_view_clip_bounds cfig == IntersectingRoomClipBoundaries
+        = setLayer DebugLayer $ f (_roomClipping w)
+    | otherwise = []
+  where
+    f (x:xs) = g x xs <> f xs
+    f [] = mempty
+    g x (y:ys) | convexPolysOverlap x y = color green (polygonWire $ _cpPoints x) 
+                    <> color yellow (polygonWire $ _cpPoints y)
+                    <> g x ys
+        | otherwise = g x ys
+    g _ [] = mempty
+
+--wallFloorsToDraw :: World -> [Wall]
+--wallFloorsToDraw w = filter isVisible $ IM.elems $ wallsOnScreen w
+--  where 
+--    onScreen wall = uncurry (lineOnScreen w) $ _wlLine wall
+--    isVisible wl 
+--        | wl ^? wlDraw == Just False = False
+--        | otherwise = onScreen wl
+--
+--lineOnScreen :: World -> Point2 -> Point2 -> Bool
+--lineOnScreen w p1 p2 = pointInPolygon p1 sp 
+--    || pointInPolygon p2 sp 
+--    || any (isJust . uncurry (intersectSegSeg p1 p2)) sps
+--  where 
+--    sp = screenPolygon w
+--    sps = zip sp (tail sp ++ [head sp])
+--
+--drawWallFloor :: Wall -> Picture
+--drawWallFloor wl = if _wlOpacity wl == SeeThrough
+--    then setDepth 0.9 . color c $ polygon [x,x +.+ n2,y+.+n2, y]
+--    else blank
+--  where 
+--    (x,y) = _wlLine wl
+--    c = _wlColor wl
+--    n2 = 15 *.* (vNormal . errorNormalizeVDR $ y -.- x)
+--
+--errorNormalizeVDR :: Point2 -> Point2
+--errorNormalizeVDR (V2 0 0) = error "problem with function: errorNormalizeVDR in DodgeRendering"
+--errorNormalizeVDR p = normalizeV p

src/GraphHelp.hs

@@ -0,0 +1,8 @@
+module GraphHelp where
+import Data.Graph.Inductive
+
+mkGraphFromEdges :: Ord a => [(a,a,b)] -> Gr a b
+mkGraphFromEdges es = insMapEdges nm es gr
+  where
+    (gr,nm,_) = insMapNodes new ns empty
+    ns = concatMap (\(x,y,_) -> [x,y]) es

src/GraphVizHelp.hs

@@ -0,0 +1,9 @@
+{-# LANGUAGE TemplateHaskell #-}
+module GraphVizHelp 
+    ( module GraphVizHelp
+    , module Data.GraphViz
+    ) where
+import Data.GraphViz
+import ThirdPartyLens
+
+mkCustomLenses ''GraphvizParams

src/ThirdPartyLens.hs

@@ -0,0 +1,12 @@
+-- https://dev.to/piq9117/haskell-generating-lenses-for-third-party-libraries-1oik
+module ThirdPartyLens where
+import           Language.Haskell.TH
+import           Control.Lens.Operators
+import           Control.Lens.TH
+
+mkCustomLenses :: Name -> DecsQ
+mkCustomLenses = makeLensesWith
+  $ lensRules
+  & lensField
+  .~ (\_ _ name -> [TopName ( mkName $ nameBase name ++ "L" )]) -- you can append whatever suits your code base here, I chose to append "L"
+