Refactor, try to limit dependencies

src/Dodge/Placement/Instance/Analyser.hs

@@ -1,71 +1,45 @@
-module Dodge.Placement.Instance.Analyser 
-    ( analyser
-    ) where
---import Dodge.LevelGen.Data
---import Dodge.PlacementSpot
-import Dodge.Data
---import Dodge.Base.You
-import Dodge.Default
-import Dodge.Terminal
---import Dodge.Tree
---import Dodge.RoomLink
---import Dodge.Room.Door
---import Dodge.Room.Corridor
---import Dodge.Room.Link
---import Dodge.Room.Ngon
---import Dodge.Room.Procedural
---import Dodge.Room.Foreground
---import Dodge.Room.RoadBlock
-import Dodge.Placement.Instance
---import Dodge.Placement.Shift
---import Dodge.SoundLogic
---import Dodge.Default.Room
---import Dodge.Item.Weapon.BulletGuns
---import Dodge.Item.Weapon.Utility
---import Dodge.LevelGen.Data
---import Geometry.Data
---import Geometry
---import Padding
+module Dodge.Placement.Instance.Analyser (
+    analyser,
+) where
+
 import Color
---import Shape
---import ShapePicture
+import Dodge.Data.GenWorld
+import Dodge.Default
+import Dodge.Placement.Instance
+import Dodge.Terminal
 import LensHelp
---import Dodge.RandomHelp
 
---import qualified Data.Set as S
---import Data.Maybe
---import Data.Tree
---import Control.Monad.State
---import System.Random
-
-analyser 
-    :: ProximityRequirement
-    -> PlacementSpot
-    -> PlacementSpot
-    -> Placement
+analyser ::
+    ProximityRequirement ->
+    PlacementSpot ->
+    PlacementSpot ->
+    Placement
 analyser proxreq pslight psmc = extTrigLitPos pslight $ \tp ->
-    Just $ plSpot .~ psmc $ putTerminal
-        (themachine & mcMounts . at ObTrigger .~ _plMID tp)
-        tparams -- (linksensortotrigger tp)
+    Just $
+        plSpot .~ psmc $
+            putTerminal
+                (themachine & mcMounts . at ObTrigger .~ _plMID tp)
+                tparams -- (linksensortotrigger tp)
   where
     tparams = basicTerminal & tmScrollCommands .:~ sensorCommand
---    linksensortotrigger tp _ mc 
---        = triggers . ix (fromJust $ _plMID tp) .~ const (_sensToggle $ _mcSensor mc)
-    themachine = defaultMachine & mcColor .~ aquamarine
---        & mcUpdate .~ mcProximitySensorUpdate
-        & mcDraw .~ MachineDrawTerminal
-        & mcHP .~ 100
-        & mcSensor .~ defaultProximitySensor {_proxRequirement = proxreq}
+    --    linksensortotrigger tp _ mc
+    --        = triggers . ix (fromJust $ _plMID tp) .~ const (_sensToggle $ _mcSensor mc)
+    themachine =
+        defaultMachine & mcColor .~ aquamarine
+            --        & mcUpdate .~ mcProximitySensorUpdate
+            & mcDraw .~ MachineDrawTerminal
+            & mcHP .~ 100
+            & mcSensor .~ defaultProximitySensor{_proxRequirement = proxreq}
 
 --this can probably be deleted
 --mcProximitySensorUpdate :: Machine -> World -> World
---mcProximitySensorUpdate mc w = case 
+--mcProximitySensorUpdate mc w = case
 --        (_proxStatus sens
 --        , _sensToggle sens
---        , mcProxTest mc w 
+--        , mcProxTest mc w
 --        , dist (_crPos ycr) (_mcPos mc) < _proxDist sens) of
 --    (_,True,_,_) -> w
---    (_,False,True,True) -> w 
+--    (_,False,True,True) -> w
 --            & machines . ix (_mcID mc) . mcSensor . sensToggle .~ True
 --            & playsound dedaS
 --            & machines . ix (_mcID mc) . mcSensor . proxStatus .~ IsClose

src/Dodge/Placement/Instance/Block.hs

@@ -1,26 +1,28 @@
 module Dodge.Placement.Instance.Block where
-import Dodge.Data
-import Geometry
-import Color
-import LensHelp
-import Dodge.Default.Wall
-import Dodge.Default.Block
 
---decoratedBlock :: (Block -> Shape) -> Material -> Color -> Float -> [Point2] -> PSType
+import Color
+import Dodge.Data.GenWorld
+import Dodge.Default.Block
+import Dodge.Default.Wall
+import Geometry
+import LensHelp
+
 decoratedBlock :: BlSh -> Material -> Color -> Float -> [Point2] -> PSType
 decoratedBlock decf mat col h ps = PutBlock bl wl $ reverse ps
   where
-    bl = defaultBlock
-        & blDraw .~ BlockDraws [BlockDrawColHeightPoss col h (reverse ps),BlockDrawBlSh decf]
+    bl =
+        defaultBlock
+            & blDraw .~ BlockDraws [BlockDrawColHeightPoss col h (reverse ps), BlockDrawBlSh decf]
             --(\bl' -> noPic (colorSH col (upperPrismPoly h $ reverse ps) <> decf bl'))
-        & blHeight .~ h
-        & blMaterial .~ mat
-    wl = defaultWall 
-        & wlColor .~ col 
-        & wlRotateTo .~ False  
-        & wlOpacity .~ SeeAbove
-        & wlMaterial .~ mat
-        & wlHeight .~ h
+            & blHeight .~ h
+            & blMaterial .~ mat
+    wl =
+        defaultWall
+            & wlColor .~ col
+            & wlRotateTo .~ False
+            & wlOpacity .~ SeeAbove
+            & wlMaterial .~ mat
+            & wlHeight .~ h
 
 lowBlock :: Material -> Color -> Float -> [Point2] -> PSType
 lowBlock = decoratedBlock BlShMempty

src/Dodge/Placement/Instance/Button.hs

@@ -1,85 +1,129 @@
 module Dodge.Placement.Instance.Button where
-import Dodge.Data
-import Dodge.LightSource
+
 import Color
-import Geometry
+import Control.Lens
+import Data.Maybe
+import Dodge.Data.GenWorld
 import Dodge.LevelGen.Data
 import Dodge.LevelGen.Switch
+import Dodge.LightSource
 import Dodge.Placement.Instance.LightSource
 import Dodge.PlacementSpot
-
-import Data.Maybe
-import Control.Lens
+import Geometry
 
 triggerSwitchSPic :: ButtonDraw -> PlacementSpot -> Placement
-triggerSwitchSPic sdraw ps = psPtCont ps (PutTrigger False)
-    $ \tp -> Just $ pContID ps (PutButton (makeSwitchSPic sdraw (SetTrigger True $ trigid tp) 
-        (SetTrigger False $ trigid tp))) 
-                    (const Nothing)
+triggerSwitchSPic sdraw ps = psPtCont ps (PutTrigger False) $
+    \tp ->
+        Just $
+            pContID
+                ps
+                ( PutButton
+                    ( makeSwitchSPic
+                        sdraw
+                        (SetTrigger True $ trigid tp)
+                        (SetTrigger False $ trigid tp)
+                    )
+                )
+                (const Nothing)
   where
     trigid tp = fromJust $ _plMID tp
 
 triggerSwitchSPicLight :: ButtonDraw -> PlacementSpot -> Placement
-triggerSwitchSPicLight sdraw ps = psPtCont ps (PutTrigger False)
-    $ \tp -> Just $ pContID atFstLnkOut (PutLS thels)
-    $ \lsid -> Just 
-        $ pContID ps (PutButton (makeSwitchSPic sdraw (oneff lsid $ trigid tp) (offeff lsid $ trigid tp))) 
-                    (const Nothing)
+triggerSwitchSPicLight sdraw ps = psPtCont ps (PutTrigger False) $
+    \tp -> Just $
+        pContID atFstLnkOut (PutLS thels) $
+            \lsid ->
+                Just $
+                    pContID
+                        ps
+                        (PutButton (makeSwitchSPic sdraw (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]
+    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)
+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)
-    $ \plmnt -> jps0' (PutButton (makeButton col (changeLight . fromJust $ _plMID plmnt)) {_btPos = V2 0 (-1), _btRot = pi})
-                subpl <&> plSpot .~ _plSpot plmnt
+putLitButOnPos ::
+    Color ->
+    PlacementSpot ->
+    (Placement -> Maybe Placement) ->
+    Placement
+putLitButOnPos col theps subpl =
+    plSpot .~ theps $
+        mntLSOn aShape (Just col) ls 0 (V3 0 (-40) 40) $
+            \plmnt ->
+                jps0'
+                    (PutButton (makeButton col (changeLight . fromJust $ _plMID plmnt)){_btPos = V2 0 (-1), _btRot = pi})
+                    subpl
+                    <&> plSpot
+                    .~ _plSpot plmnt
   where
     changeLight lsid = SetLSCol (V3 0 0.5 0) lsid
     ls = lsRadCol 75 (V3 0.5 0 0)
 
 -- creates a lit external trigger, passes the trigger placement forward
 extTrigLitPos :: PlacementSpot -> (Placement -> Maybe Placement) -> Placement
-extTrigLitPos ps f = psPtCont ps (PutTrigger False)
-    $ \tp -> Just $ pContID (ps' tp) (PutLS thels)
-    $ \lsid -> Just $ pContID (ps' tp) (PutMod $ themod lsid tp)
-    $ const (f tp)
+extTrigLitPos ps f = psPtCont ps (PutTrigger False) $
+    \tp -> Just $
+        pContID (ps' tp) (PutLS thels) $
+            \lsid ->
+                Just $
+                    pContID (ps' tp) (PutMod $ themod lsid tp) $
+                        const (f tp)
   where
     ps' tp = _plSpot tp
-    themod lsid tp = ModIDID
-        {_mdID = 0
-        ,_mdExternalID1 = lsid
-        ,_mdExternalID2 = fromJust $ _plMID tp
-        ,_mdUpdate = MdTrigIf (MdSetLSCol (V3 0 0.5 0)) (MdSetLSCol (V3 0.5 0 0))
-        }
+    themod lsid tp =
+        ModIDID
+            { _mdID = 0
+            , _mdExternalID1 = lsid
+            , _mdExternalID2 = fromJust $ _plMID tp
+            , _mdUpdate = MdTrigIf (MdSetLSCol (V3 0 0.5 0)) (MdSetLSCol (V3 0.5 0 0))
+            }
     thels = lsColPosRad (V3 0.5 0 0) (V3 0 0 78) 75
 
 putLitButOnPosExtTrig :: Color -> PlacementSpot -> Placement
 putLitButOnPosExtTrig col thePS = putLitButOnPosExtTrig' col thePS (const . const . const Nothing)
 
-putLitButOnPosExtTrig' :: Color 
-    -> PlacementSpot 
-    -> (Placement -> Placement -> Placement -> Maybe Placement)
-    -> Placement
-putLitButOnPosExtTrig' col thePS cnt
-    = psPtCont thePS (PutTrigger False)
-    $ \tp -> Just $ plSpot .~ _plSpot tp $ mntLSOn aShape (Just col) ls 0 (V3 0 (-40) 40)
-    $ \plmnt -> jps0' (PutButton 
-            (makeButton col (WorldEffects [changeLight (fromJust $ _plMID plmnt), oneff (trigid tp)])) 
-                {_btPos = V2 0 (-1), _btRot = pi})
-            (cnt tp plmnt) <&> plSpot .~ _plSpot plmnt
+putLitButOnPosExtTrig' ::
+    Color ->
+    PlacementSpot ->
+    (Placement -> Placement -> Placement -> Maybe Placement) ->
+    Placement
+putLitButOnPosExtTrig' col thePS cnt =
+    psPtCont thePS (PutTrigger False) $
+        \tp -> Just $
+            plSpot .~ _plSpot tp $
+                mntLSOn aShape (Just col) ls 0 (V3 0 (-40) 40) $
+                    \plmnt ->
+                        jps0'
+                            ( PutButton
+                                (makeButton col (WorldEffects [changeLight (fromJust $ _plMID plmnt), oneff (trigid tp)]))
+                                    { _btPos = V2 0 (-1)
+                                    , _btRot = pi
+                                    }
+                            )
+                            (cnt tp plmnt)
+                            <&> plSpot
+                            .~ _plSpot plmnt
   where
     trigid tp = fromJust $ _plMID tp
     oneff tid = SetTrigger True tid

src/Dodge/Placement/Instance/Creature.hs

@@ -1,9 +1,9 @@
 module Dodge.Placement.Instance.Creature where
---import Dodge.LevelGen.Data
-import Dodge.Data
-import RandomHelp
+
 import Dodge.Creature.ArmourChase
 import Dodge.Creature.ChaseCrit
+import Dodge.Data.GenWorld
+import RandomHelp
 
 randC1 :: PSType
 randC1 = RandPS $ takeOne $ map PutCrit $ armourChaseCrit : replicate 50 chaseCrit

src/Dodge/Placement/Instance/Door.hs

@@ -1,76 +1,112 @@
-module Dodge.Placement.Instance.Door 
-    ( putDoubleDoor
-    , putAutoDoor
-    , putDoubleDoorThen
-    , switchDoor -- not used 9/3/22
-    ) where
-import Dodge.Data
-import Dodge.Default.Door
+module Dodge.Placement.Instance.Door (
+    putDoubleDoor,
+    putAutoDoor,
+    putDoubleDoorThen,
+    switchDoor, -- not used 9/3/22
+) where
+
 import Color
-import Geometry
+import Control.Lens
+import Dodge.Data.CreatureEffect
+import Dodge.Data.GenWorld
+import Dodge.Default.Door
 import Dodge.LevelGen.Data
 import Dodge.LevelGen.Switch
-
-import Control.Lens
+import Geometry
 
 putDoubleDoor :: EdgeObstacle -> Wall -> WdBl -> Point2 -> Point2 -> Float -> Placement
-putDoubleDoor eo wl cond a b speed 
-    = putDoubleDoorThen eo wl cond 1 a b speed (const $ const Nothing)
+putDoubleDoor eo wl cond a b speed =
+    putDoubleDoorThen eo wl cond 1 a b speed (const $ const Nothing)
 
-putDoubleDoorThen ::EdgeObstacle ->  Wall -> WdBl 
-    -> Float -> Point2 -> Point2 -> Float 
-    -> (Placement -> Placement -> Maybe Placement)
-    -> Placement
-putDoubleDoorThen eo wl cond soff a b speed cont 
-     = doorBetween eo wl cond soff a half speed
-    $ \pl1 -> Just $ doorBetween eo wl cond soff b half speed
-    $ \pl2 -> cont pl1 pl2
+putDoubleDoorThen ::
+    EdgeObstacle ->
+    Wall ->
+    WdBl ->
+    Float ->
+    Point2 ->
+    Point2 ->
+    Float ->
+    (Placement -> Placement -> Maybe Placement) ->
+    Placement
+putDoubleDoorThen eo wl cond soff a b speed cont =
+    doorBetween eo wl cond soff a half speed $
+        \pl1 -> Just $
+            doorBetween eo wl cond soff b half speed $
+                \pl2 -> cont pl1 pl2
   where
     half = 0.5 *.* (a +.+ b)
 
-doorBetween :: EdgeObstacle -> Wall -> WdBl -> Float -> Point2 -> Point2 -> Float ->
-    (Placement -> Maybe Placement) -> Placement
+doorBetween ::
+    EdgeObstacle ->
+    Wall ->
+    WdBl ->
+    Float ->
+    Point2 ->
+    Point2 ->
+    Float ->
+    (Placement -> Maybe Placement) ->
+    Placement
 doorBetween eo wl cond soff pa pb speed g = case divideLine 40 pa pb of
-    [x,y] -> ptCont (PutSlideDr adoor wl eo soff x y) g
-    (x:y:zs) -> divideDoorPane Nothing wl cond (soff - dist y pb) speed (zip (x:y:zs) (y:zs)) g
+    [x, y] -> ptCont (PutSlideDr adoor wl eo soff x y) g
+    (x : y : zs) -> divideDoorPane Nothing wl cond (soff - dist y pb) speed (zip (x : y : zs) (y : zs)) g
     _ -> undefined
   where
-    adoor = defaultDoor
-        & drTrigger .~ cond
-        & drSpeed   .~ speed
+    adoor =
+        defaultDoor
+            & drTrigger .~ cond
+            & drSpeed .~ speed
 
-divideDoorPane :: Maybe Int -> Wall -> WdBl -> Float -> Float 
-    -> [(Point2,Point2)] -> (Placement -> Maybe Placement) -> Placement
+divideDoorPane ::
+    Maybe Int ->
+    Wall ->
+    WdBl ->
+    Float ->
+    Float ->
+    [(Point2, Point2)] ->
+    (Placement -> Maybe Placement) ->
+    Placement
 divideDoorPane mid wl cond soff speed 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
+    (p : ps) -> ptCont (adoor p) $ \pl -> Just $ divideDoorPane (_plMID pl) wl cond soff speed ps g
     _ -> undefined
   where
-    adoor (x,y) = PutSlideDr thedoor wl DoorObstacle soff x y
-    thedoor = defaultDoor & drSpeed .~ speed & drTrigger .~ cond
-        & drPushedBy .~ maybe PushesItself PushedBy mid
+    adoor (x, y) = PutSlideDr thedoor wl DoorObstacle soff x y
+    thedoor =
+        defaultDoor & drSpeed .~ speed & drTrigger .~ cond
+            & drPushedBy .~ maybe PushesItself PushedBy mid
 
 putAutoDoor :: Point2 -> Point2 -> Placement
-putAutoDoor a b = PlacementUsingPos (addZ 0 a)
-    $ \az -> PlacementUsingPos (addZ 0 b)
-    $ \bz -> putDoubleDoor AutoDoorObstacle defaultAutoWall
-        (cond az bz) a b 3
+putAutoDoor a b = PlacementUsingPos (addZ 0 a) $
+    \az -> PlacementUsingPos (addZ 0 b) $
+        \bz ->
+            putDoubleDoor
+                AutoDoorObstacle
+                defaultAutoWall
+                (cond az bz)
+                a
+                b
+                3
   where
     --cond az bz = any (crNearSeg 40 (stripZ az) (stripZ bz)) . IM.filter isAnimate . _creatures
     cond az bz = WdBlCrFilterNearPoint 40 (0.5 *.* (stripZ az +.+ stripZ bz)) CrIsAnimate
-       --  any (crNearPoint 40 (0.5 *.* (stripZ az +.+ stripZ bz))) 
-       -- . IM.filter isAnimate . _creatures
+
+--  any (crNearPoint 40 (0.5 *.* (stripZ az +.+ stripZ bz)))
+-- . IM.filter isAnimate . _creatures
 
 switchDoor :: Point2 -> Float -> Point2 -> Point2 -> Color -> Placement
-switchDoor btpos btrot dra drb col = pContID (PS btpos btrot) 
+switchDoor btpos btrot dra drb col = pContID
+    (PS btpos btrot)
     (PutButton $ makeSwitch col red NoWorldEffect NoWorldEffect)
-    $ \btid -> jsps0J (doorbetween btid dra drc)
-    $          sps0   (doorbetween btid drb drc)
+    $ \btid ->
+        jsps0J (doorbetween btid dra drc) $
+            sps0 (doorbetween btid drb drc)
   where
     doorbetween btid a b = PutSlideDr thedoor (switchWallCol col) DoorObstacle 1 a b
       where
-        thedoor = defaultDoor
-            & drTrigger .~ WdBlBtOn btid
-            & drSpeed   .~ 2
+        thedoor =
+            defaultDoor
+                & drTrigger .~ WdBlBtOn btid
+                & drSpeed .~ 2
     drc = 0.5 *.* (dra +.+ drb)
-    --cond btid w' = _btState (_buttons w' IM.! btid) == BtOn
+
+--cond btid w' = _btState (_buttons w' IM.! btid) == BtOn

src/Dodge/Placement/Instance/LightSource.hs

@@ -1,58 +1,70 @@
 module Dodge.Placement.Instance.LightSource where
-import Dodge.Data
-import Dodge.LightSource
+
+import Color
+import Control.Lens
+import Data.Maybe
+import Dodge.Creature.Inanimate
+import Dodge.Data.GenWorld
+import Dodge.Default
 import Dodge.LevelGen.Data
+import Dodge.LightSource
 import Dodge.Room.Foreground
 import Geometry
---import Geometry.Vector3D
-import Dodge.Creature.Inanimate
-import Shape.Data
-import Dodge.Default
 import RandomHelp
-import Color
 import Shape
 import ShapePicture
 
-import Control.Lens
-import Data.Maybe
+propLSThen ::
+    PropUpdate ->
+    PrWdLsLs -> --(Prop -> World -> LightSource -> LightSource)
+    LightSource ->
+    Prop ->
+    -- | continuation, access to ls and prop placements
+    (Placement -> Placement -> Maybe Placement) ->
+    Placement
+propLSThen propf lsf ls prop cont = pt0 (PutLS ls) $
+    \lspl ->
+        Just $
+            pt0 (PutProp $ prop & prUpdate .~ PropUpdates [propf, PropUpdateLS (fromJust $ _plMID lspl) lsf]) $
+                cont lspl
 
-propLSThen :: PropUpdate
-    -> PrWdLsLs --(Prop -> World -> LightSource -> LightSource)
-    -> LightSource 
-    -> Prop
-    -> (Placement -> Placement -> Maybe Placement) -- ^ continuation, access to ls and prop placements
-    -> Placement
-propLSThen propf lsf ls prop cont = pt0 (PutLS ls)
-    $ \lspl -> Just $ pt0 (PutProp $ prop & prUpdate .~ PropUpdates [propf,PropUpdateLS (fromJust $ _plMID lspl) lsf])
-    $ cont lspl
+moveLSThen ::
+    WdP2f -> --(World -> (Point2,Float))
 
-moveLSThen :: WdP2f --(World -> (Point2,Float))
-    -> Point3   -- ^ light source offset
-    -> Shape
-    -> (Placement -> Placement -> Maybe Placement)
-    -> Placement
+    -- | light source offset
+    Point3 ->
+    Shape ->
+    (Placement -> Placement -> Maybe Placement) ->
+    Placement
 moveLSThen posf off sh = propLSThen (PropUpdatePosition posf) (PrWdLsSetPosition posf off) thels theprop
   where
     --lsupdate _ w = lsParam . lsPos .~ addZ 0 (fst (posf w)) +.+.+ rotate3z (snd (posf w)) off
     thels = defaultLS
-    theprop = ShapeProp
-        { _prPos = 0
-        , _prID = 0
-        , _prRot = 0
-        , _prUpdate = PropUpdateId
-        --, _prDraw = PropDrawSPic $ noPic $ uncurryV translateSHf (_prPos pr) $ rotateSH (_pjRot pr) sh
-        , _prDraw = PropDrawFlatTranslate $ PropDrawSPic $ noPic sh
-        , _prToggle = True
-        }
-    
+    theprop =
+        ShapeProp
+            { _prPos = 0
+            , _prID = 0
+            , _prRot = 0
+            , _prUpdate = PropUpdateId
+            , --, _prDraw = PropDrawSPic $ noPic $ uncurryV translateSHf (_prPos pr) $ rotateSH (_pjRot pr) sh
+              _prDraw = PropDrawFlatTranslate $ PropDrawSPic $ noPic sh
+            , _prToggle = True
+            }
+
 -- | mount a light source on a shape
-mntLSOn
-    :: (Point2 -> Point3 -> Shape) -- ^ function describing the mount shape
-    -> Maybe Color  -- ^ describing a possible color override for the shape
-    -> LightSource -> Point2 -> Point3 -> (Placement -> Maybe Placement) -> Placement
-mntLSOn shapeF mcol ls wallp lsp@(V3 lx ly _)
-    = ps0jPushPS (putShape . setCol $ shapeF wallp lsp)
-    . pt0 (PutLS $ ls & lsParam . lsPos .~ lsp')
+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 _) =
+    ps0jPushPS (putShape . setCol $ shapeF wallp lsp)
+        . pt0 (PutLS $ ls & lsParam . lsPos .~ lsp')
   where
     lsp' = lsp -.-.- V3 x y 1
     -- hack! perturb the light position
@@ -63,17 +75,19 @@ iShape :: Point2 -> Point3 -> Shape
 iShape wp (V3 x y z) = thinHighBar z wp (V2 x y)
 
 lShape :: Point2 -> Point3 -> Shape
-lShape wp (V3 x y z) = thinHighBar z wallposUp turnpos
-        <> thinHighBar z turnpos (V2 x y)    
+lShape wp (V3 x y z) =
+    thinHighBar z wallposUp turnpos
+        <> thinHighBar z turnpos (V2 x y)
   where
     n = vNormal (wp -.- V2 x y)
     wallposUp = wp +.+ n
     turnpos = V2 x y +.+ n
 
 jShape :: Point2 -> Point3 -> Shape
-jShape wallpos (V3 x y z) = thinHighBar z wallposUp turn1
-    <> thinHighBar z turn1 turn2
-    <> thinHighBar z turn2 endpos
+jShape wallpos (V3 x y z) =
+    thinHighBar z wallposUp turn1
+        <> thinHighBar z turn1 turn2
+        <> thinHighBar z turn2 endpos
   where
     n = vNormal (wallpos -.- V2 x y)
     wallposUp = wallpos +.+ n
@@ -84,8 +98,8 @@ jShape wallpos (V3 x y z) = thinHighBar z wallposUp turn1
 
 liShape :: Point2 -> Point3 -> Shape
 liShape wallpos (V3 x y z) =
-     thinHighBar z wallposUp turnpos
-    <> thinHighBar z turnpos (V2 x y)
+    thinHighBar z wallposUp turnpos
+        <> thinHighBar z turnpos (V2 x y)
   where
     n = vNormal (V2 x y -.- wallpos)
     wallposUp = wallpos +.+ n
@@ -93,14 +107,14 @@ liShape wallpos (V3 x y z) =
 
 aShape :: Point2 -> Point3 -> Shape
 aShape wallpos (V3 x y z) =
-    girder (z+2) 20 10 pout wallpos
+    girder (z + 2) 20 10 pout wallpos
   where
     pout = V2 x y -.- 2 *.* squashNormalizeV (V2 x y -.- wallpos)
 
 vShape :: Point2 -> Point3 -> Shape
 vShape wallpos (V3 x y z) =
     thinHighBar z wallposUp lxy
-    <> thinHighBar z wallposDown lxy
+        <> thinHighBar z wallposDown lxy
   where
     lxy = V2 x y
     n = vNormal (wallpos -.- lxy)
@@ -114,52 +128,65 @@ mntLSCol :: (Point2 -> Point3 -> Shape) -> Color -> Point2 -> Point3 -> Placemen
 mntLSCol shp col wallp lampp = mntLSOn shp (Just col) defaultLS wallp lampp (const Nothing)
 
 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)
+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
 
-mntLSCond :: (Point2 -> Point3 -> Shape) 
---    -> (RoomPos -> Room -> Maybe (PlacementSpot,RoomPos)) 
-    -> PlacementSpot
-    -> Placement
-mntLSCond shp ps = -- updatePSToLevel 1 (const $ PSLnk shift (const id) Nothing) $ 
+mntLSCond ::
+    (Point2 -> Point3 -> Shape) ->
+    --    -> (RoomPos -> Room -> Maybe (PlacementSpot,RoomPos))
+    PlacementSpot ->
+    Placement
+mntLSCond shp ps =
+    -- updatePSToLevel 1 (const $ PSLnk shift (const id) Nothing) $
     mntLS shp 0 (V3 0 (-20) 95)
-    & plSpot .~ ps
-    -- note that this perhaps pushes the vshape light out too far
+        & plSpot .~ ps
+
+-- note that this perhaps pushes the vshape light out too far
 
 mntLight :: Point2 -> Point2 -> Placement
 mntLight a b = RandomPlacement $ do
-    shp <- takeOne [vShape,iShape,lShape,jShape,liShape]
+    shp <- takeOne [vShape, iShape, lShape, jShape, liShape]
     return $ mntLS shp a (addZ 90 b)
 
 mntLightLnkCond :: PlacementSpot -> Placement
 mntLightLnkCond ps = RandomPlacement $ do
-    shp <- takeOne [vShape,lShape,jShape,liShape]
+    shp <- takeOne [vShape, lShape, jShape, liShape]
     return $ mntLSCond (fmap (fmap $ colorSH black) shp) ps
 
 spanLSLightI :: LightSource -> Float -> Point2 -> Point2 -> Placement
-spanLSLightI ls h a b = ps0j (PutLS $ ls & lsParam . lsPos .~ V3 x y h)
-    $ sps0 $ putShape $ thinHighBar h a b
+spanLSLightI ls h a b =
+    ps0j (PutLS $ ls & lsParam . lsPos .~ V3 x y h) $
+        sps0 $ putShape $ thinHighBar h a b
   where
     V2 x y = 0.5 *.* (a +.+ b)
 
 spanLS :: LightSource -> Point2 -> Point2 -> Placement
-spanLS ls a b = Placement 10 (PS (V2 x y) 0) (PutLS ls) Nothing
-    $ const $ const $ Just $ sps0 $ putShape $ thinHighBar h a b
+spanLS ls a b =
+    Placement 10 (PS (V2 x y) 0) (PutLS ls) Nothing $
+        const $ const $ Just $ sps0 $ putShape $ thinHighBar h a b
   where
     V3 _ _ h = _lsPos (_lsParam ls) + 5
     V2 x y = 0.5 *.* (a +.+ b)
 
 spanColLightI :: Point3 -> Float -> Point2 -> Point2 -> Placement
-spanColLightI col h a b = ps0j (PutLS $ lsColPos col (V3 x y (h-5)))
-    $ sps0 $ putShape $ thinHighBar h a b
+spanColLightI col h a b =
+    ps0j (PutLS $ lsColPos col (V3 x y (h -5))) $
+        sps0 $ putShape $ thinHighBar h a b
   where
     V2 x y = 0.5 *.* (a +.+ b)
 
 spanColLightBlackI :: Point3 -> Float -> Point2 -> Point2 -> Placement
-spanColLightBlackI col h a b = ps0j (PutLS $ lsColPos col (V3 x y (h-5)))
-    $ sps0 $ putShape $ colorSH black $ thinHighBar h a b
+spanColLightBlackI col h a b =
+    ps0j (PutLS $ lsColPos col (V3 x y (h -5))) $
+        sps0 $ putShape $ colorSH black $ thinHighBar h a b
   where
     V2 x y = 0.5 *.* (a +.+ b)
 

src/Dodge/Placement/Instance/LightSource/Cover.hs

@@ -1,35 +1,43 @@
 module Dodge.Placement.Instance.LightSource.Cover where
-import Dodge.Data
-import Geometry.Data
+
+import Dodge.Data.Prop
+import Dodge.Data.WorldEffect
 import Dodge.Default.Prop
+import Geometry.Data
+
 lampCover :: Float -> Prop
-lampCover h = ShapeProp
-    { _prPos = V2 0 0
-    , _prID  = 0
-    , _prRot = 0
-    , _prUpdate = PropRotate 0.15
-    , _prDraw = PropLampCover h
-    , _prToggle = True
-    }
+lampCover h =
+    ShapeProp
+        { _prPos = V2 0 0
+        , _prID = 0
+        , _prRot = 0
+        , _prUpdate = PropRotate 0.15
+        , _prDraw = PropLampCover h
+        , _prToggle = True
+        }
+
 lampCoverWhen :: WdBl -> Point2 -> Float -> Prop
-lampCoverWhen cond pos h = defaultProp
-    { _prPos = pos
-    , _prUpdate = PropSetToggleAnd cond (PropRotate 0.15)
-    , _prDraw = PropLampCover h
-    , _prToggle = True
-    }
+lampCoverWhen cond pos h =
+    defaultProp
+        { _prPos = pos
+        , _prUpdate = PropSetToggleAnd cond (PropRotate 0.15)
+        , _prDraw = PropLampCover h
+        , _prToggle = True
+        }
 
 doubleLampCover :: Float -> Prop
-doubleLampCover h = defaultProp
-    { _prPos = V2 0 0
-    , _prUpdate = PropRotate 0.15
-    , _prDraw = PropDoubleLampCover h
-    }
+doubleLampCover h =
+    defaultProp
+        { _prPos = V2 0 0
+        , _prUpdate = PropRotate 0.15
+        , _prDraw = PropDoubleLampCover h
+        }
 
 -- on the current (27/9/21) version of shadow stencilling, this glitches
 -- slightly when the shadow rotates towards the screen
 verticalLampCover :: Float -> Prop
-verticalLampCover h = defaultProp
-    { _prUpdate = PropRotate 0.15
-    , _prDraw = PropVerticalLampCover h
-    }
+verticalLampCover h =
+    defaultProp
+        { _prUpdate = PropRotate 0.15
+        , _prDraw = PropVerticalLampCover h
+        }

src/Dodge/Placement/Instance/LightSource/Flicker.hs

@@ -1,32 +1,39 @@
 module Dodge.Placement.Instance.LightSource.Flicker where
-import Dodge.LevelGen.Data
-import Dodge.Data
-import Data.Maybe
+
 import Control.Lens
+import Data.Maybe
+import Dodge.Data.GenWorld
+import Dodge.LevelGen.Data
 import System.Random
+
 -- Supposes the orginal placement is a light source, adds a flicker
 flickerMod :: Placement -> Maybe Placement
-flickerMod pl = Just $ sps0 $ PutMod $ ModIDTimerPoint3Bool
-    { _mdID = 0
-    , _mdExternalID = fromJust $ _plMID pl
-    , _mdUpdate = MdFlickerUpdate
-    , _mdTimer  = 10
-    , _mdPoint3  = 0.8
-    , _mdBool = True
-    }
+flickerMod pl =
+    Just $
+        sps0 $
+            PutMod $
+                ModIDTimerPoint3Bool
+                    { _mdID = 0
+                    , _mdExternalID = fromJust $ _plMID pl
+                    , _mdUpdate = MdFlickerUpdate
+                    , _mdTimer = 10
+                    , _mdPoint3 = 0.8
+                    , _mdBool = True
+                    }
 
 flickerUpdate :: Modification -> World -> World
-flickerUpdate md w 
+flickerUpdate md w
     | _mdTimer md > 0 = w & cWorld . modifications . ix mdid . mdTimer -~ 1
-    | otherwise = w & cWorld . lightSources . ix lsid . lsParam . lsCol .~ mdcol
-        & cWorld . modifications . ix mdid 
-            %~ ( (mdTimer .~ newtime) . (mdPoint3 .~ lscol) . (mdBool %~ not) )
+    | otherwise =
+        w & cWorld . lightSources . ix lsid . lsParam . lsCol .~ mdcol
+            & cWorld . modifications . ix mdid
+                %~ ((mdTimer .~ newtime) . (mdPoint3 .~ lscol) . (mdBool %~ not))
   where
     mdcol = _mdPoint3 md
     lscol = w ^?! cWorld . lightSources . ix lsid . lsParam . lsCol -- _lsCol $ _lsParam $ _lightSources w IM.! lsid
     lsid = _mdExternalID md
     mdid = _mdID md
-    timerange 
-        | _mdBool md = (2,10)
-        | otherwise  = (2,30)
-    (newtime,_) = randomR timerange $ _randGen w
+    timerange
+        | _mdBool md = (2, 10)
+        | otherwise = (2, 30)
+    (newtime, _) = randomR timerange $ _randGen w

src/Dodge/Placement/Instance/Sensor.hs

@@ -1,48 +1,55 @@
-module Dodge.Placement.Instance.Sensor
-    ( lightSensor
-    , damageSensor
-    , sensorSPic -- this should be moved
-    ) where
+module Dodge.Placement.Instance.Sensor (
+    lightSensor,
+    damageSensor,
+    sensorSPic, -- this should be moved
+) where
+
 import Color
-import Dodge.LightSource
-import Dodge.Data
-import Dodge.LevelGen.Data
+import Control.Lens
+import qualified Data.Map.Strict as M
+import Dodge.Data.GenWorld
 import Dodge.Default
+import Dodge.LevelGen.Data
+import Dodge.LightSource
 import Dodge.Placement.TopDecoration
 import Geometry
-import ShapePicture
 import Shape
+import ShapePicture
 
-import qualified Data.Map.Strict as M
-import Control.Lens
+damageSensor ::
+    DamageType ->
+    Float ->
+    Maybe Int ->
+    PlacementSpot ->
+    Placement
+damageSensor dt wdth mtrid ps = pContID ps (PutLS $ lsPosCol (V3 0 0 30) 0.1) $
+    \lsid -> Just $
+        spNoID ps $
+            PutUsingGenParams $
+                \gw ->
+                    (,) gw $
+                        PutMachine
+                            (reverse $ square wdth)
+                            ( defaultMachine
+                                & mcColor .~ yellow
+                                & mcMounts . at ObTrigger .~ mtrid
+                                & mcMounts . at ObLightSource ?~ lsid
+                                & mcDraw .~ MachineDrawDamageSensor wdth (_sensorCoding (_genParams (_cWorld gw)) M.! dt)
+                                & mcSensor .~ DamageSensor False 0 dt
+                            )
+                            defaultSensorWall
 
-damageSensor
-    :: DamageType
-    -> Float
-    -> Maybe Int
-    -> PlacementSpot 
-    -> Placement
-damageSensor dt wdth mtrid ps = pContID ps (PutLS $ lsPosCol (V3 0 0 30) 0.1)
-    $ \lsid -> Just $ spNoID ps $ PutUsingGenParams 
-    $ \gw -> (,) gw $ PutMachine (reverse $ square wdth) 
-        (defaultMachine
-            & mcColor .~ yellow
-            & mcMounts . at ObTrigger .~ mtrid
-            & mcMounts . at ObLightSource ?~ lsid
-            & mcDraw .~ MachineDrawDamageSensor wdth (_sensorCoding (_genParams (_cWorld gw)) M.! dt)
-            & mcSensor .~ DamageSensor False 0 dt
-        )
-        defaultSensorWall
-
-lightSensor :: Float
-    -> Maybe Int
-    -> PlacementSpot 
-    -> Placement
+lightSensor ::
+    Float ->
+    Maybe Int ->
+    PlacementSpot ->
+    Placement
 lightSensor = damageSensor LASERING
 
-sensorSPic :: Float -> (PaletteColor,DecorationShape) -> Machine -> SPic
-sensorSPic wdth (pc,ds) mc = noPic 
-    $  colorSH (_mcColor mc) (upperPrismPoly 25 (square wdth))
-    <> decorationToShape ds wdth wdth 25 col col
+sensorSPic :: Float -> (PaletteColor, DecorationShape) -> Machine -> SPic
+sensorSPic wdth (pc, ds) mc =
+    noPic $
+        colorSH (_mcColor mc) (upperPrismPoly 25 (square wdth))
+            <> decorationToShape ds wdth wdth 25 col col
   where
     col = paletteToColor pc

src/Dodge/Placement/Instance/Tank.hs

@@ -1,47 +1,52 @@
-module Dodge.Placement.Instance.Tank 
-    ( tankSquareDec
-    , roundTank
-    , roundTankCross
-    ) where
-import Dodge.Data
+module Dodge.Placement.Instance.Tank (
+    tankSquareDec,
+    roundTank,
+    roundTankCross,
+) where
+
+import Color
+import Dodge.Data.GenWorld
 import Dodge.LevelGen.Data
-import Dodge.Room.Foreground
 import Dodge.Placement.Instance.Block
+import Dodge.Room.Foreground
 import Geometry
 import Shape
-import Color
---import LensHelp
---import Quaternion
 
-tankSquareDec :: (Float -> Float -> Float -> Color -> Color -> Shape) 
-    -> Color -> Color -> Placement
+tankSquareDec ::
+    (Float -> Float -> Float -> Color -> Color -> Shape) ->
+    Color ->
+    Color ->
+    Placement
 tankSquareDec dec = tankShape (square 20) (dec 20 20 31)
 
 tankShape :: [Point2] -> (Color -> Color -> Shape) -> Color -> Color -> Placement
 tankShape baseshape facade col col' = sps0 $ decoratedBlock (BlShConst $ facade col col') Metal col 31 baseshape
+
 --    = sps0 $ PutBlock bl wl $ reverse baseshape
 --  where
 --    bl = defaultBlock
 --        & blDraw .~ const (noPic $ colorSH col (upperPrismPoly 31 $ reverse baseshape) <> facade col col')
 --        & blDeath .~ const id
---    wl = defaultWall 
---        & wlColor .~ col 
---        & wlRotateTo .~ False  
+--    wl = defaultWall
+--        & wlColor .~ col
+--        & wlRotateTo .~ False
 --        & wlOpacity .~ SeeAbove
 --        & wlMaterial .~ Metal
 
 --    = ps0jPushPS
 --    (PutShape $ colorSH col (upperPrismPoly 31 baseshape) <> facade col col')
---    $ sps0 $ PutWall baseshape defaultWall 
+--    $ sps0 $ PutWall baseshape defaultWall
 --        {_wlUnshadowed = False, _wlColor = col, _wlRotateTo = False, _wlOpacity = SeeAbove}
 
 roundTank :: Color -> Color -> Placement
-roundTank = tankShape (polyCirc 4 20) 
-    $ \_ c' -> colorSH c' $ foldMap toprail (take 8 [0,pi/4..]) 
+roundTank = tankShape (polyCirc 4 20) $
+    \_ c' -> colorSH c' $ foldMap toprail (take 8 [0, pi / 4 ..])
   where
-    toprail a = rotateSH a $ thinHighBar 31 (V2 0 20) (rotateV (pi/4) $ V2 0 20)
+    toprail a = rotateSH a $ thinHighBar 31 (V2 0 20) (rotateV (pi / 4) $ V2 0 20)
 
 roundTankCross :: Color -> Color -> Placement
-roundTankCross = tankShape (polyCirc 4 20) 
-    $ \_ c -> colorSH c $ thinHighBar 31 (V2 20 0) (V2 (-20) 0)
-        <> thinHighBar 31 (V2 0 20) (V2 0 (-20))
+roundTankCross = tankShape (polyCirc 4 20) $
+    \_ c ->
+        colorSH c $
+            thinHighBar 31 (V2 20 0) (V2 (-20) 0)
+                <> thinHighBar 31 (V2 0 20) (V2 0 (-20))

src/Dodge/Placement/Instance/Terminal.hs

@@ -1,62 +1,67 @@
---{-# LANGUAGE TupleSections #-}
-module Dodge.Placement.Instance.Terminal 
-    ( putMessageTerminal
-    , putTerminal
---    , simpleTermMessage
-    , terminalColor
---    , accessTerminal
-    ) where
-import Dodge.Data
-import Dodge.LevelGen.Data
-import Dodge.Default
-import Dodge.SoundLogic
+module Dodge.Placement.Instance.Terminal (
+    putMessageTerminal,
+    putTerminal,
+    terminalColor,
+) where
+
 import Color
+import Data.Maybe
+import Dodge.Data.GenWorld
+import Dodge.Default
+import Dodge.LevelGen.Data
+import Dodge.SoundLogic
 import Geometry
 import LensHelp
 
-import Data.Maybe
-
 putTerminal :: Machine -> Terminal -> Placement
-putTerminal mc tm 
-    = ps0PushPS (PutTerminal tm) 
-    $ \tmpl -> Just $ ps0PushPS (PutButton termButton)
-    $ \btpl -> Just $ pt0 
-        (PutMachine (reverse $ square 10)
-            (mc & mcMounts . at ObButton ?~ fromJust (_plMID btpl)
-                & mcCloseSound ?~ fridgeHumS)       
-            defaultSensorWall
-        )
-    $ \mcpl -> Just $ sps0 $ PutWorldUpdate $ const (setids tmpl btpl mcpl) 
+putTerminal mc tm =
+    ps0PushPS (PutTerminal tm) $
+        \tmpl -> Just $
+            ps0PushPS (PutButton termButton) $
+                \btpl -> Just $
+                    pt0
+                        ( PutMachine
+                            (reverse $ square 10)
+                            ( mc & mcMounts . at ObButton ?~ fromJust (_plMID btpl)
+                                & mcCloseSound ?~ fridgeHumS
+                            )
+                            defaultSensorWall
+                        )
+                        $ \mcpl -> Just $ sps0 $ PutWorldUpdate $ const (setids tmpl btpl mcpl)
   where
-    setids tmpl btpl mcpl w = w
-        & cWorld . terminals . ix tmid . tmButtonID .~ btid
-        & cWorld . terminals . ix tmid . tmMachineID .~ mcid
-        & cWorld . machines  . ix mcid . mcMounts . at ObTerminal ?~ tmid
-        & cWorld . buttons   . ix btid . btTermMID ?~ tmid
+    setids tmpl btpl mcpl w =
+        w
+            & cWorld . terminals . ix tmid . tmButtonID .~ btid
+            & cWorld . terminals . ix tmid . tmMachineID .~ mcid
+            & cWorld . machines . ix mcid . mcMounts . at ObTerminal ?~ tmid
+            & cWorld . buttons . ix btid . btTermMID ?~ tmid
       where
         tmid = fromJust (_plMID tmpl)
         btid = fromJust (_plMID btpl)
         mcid = fromJust (_plMID mcpl)
 
 putMessageTerminal :: Color -> Terminal -> Placement
-putMessageTerminal col = putTerminal $ defaultMachine
-    & mcColor .~ col
-    & mcDraw .~ MachineDrawTerminal --terminalSPic
-    & mcHP .~ 100
+putMessageTerminal col =
+    putTerminal $
+        defaultMachine
+            & mcColor .~ col
+            & mcDraw .~ MachineDrawTerminal --terminalSPic
+            & mcHP .~ 100
 
 termButton :: Button
-termButton = Button
-    { _btPict   = DrawNoButton
-    , _btPos    = 0
-    , _btRot    = 0
-    , _btEvent  = ButtonAccessTerminal
-    , _btID     = 0
-    , _btText   = "TERMINAL"
-    , _btState  = BtOff
-    , _btTermMID = Nothing
-    , _btName   = ""
-    , _btColor  = dark magenta
-    }
+termButton =
+    Button
+        { _btPict = DrawNoButton
+        , _btPos = 0
+        , _btRot = 0
+        , _btEvent = ButtonAccessTerminal
+        , _btID = 0
+        , _btText = "TERMINAL"
+        , _btState = BtOff
+        , _btTermMID = Nothing
+        , _btName = ""
+        , _btColor = dark magenta
+        }
 
 terminalColor :: Color
 terminalColor = dark magenta

src/Dodge/Placement/Instance/Turret.hs

@@ -1,87 +1,99 @@
 module Dodge.Placement.Instance.Turret where
-import Color
-import Dodge.Data
-import Dodge.LevelGen.Data
-import Dodge.Default
-import Dodge.Movement.Turn
-import Dodge.FloorItem
-import Dodge.Wall.Delete
-import Dodge.WorldEvent.Explosion
-import Dodge.Item.Weapon.BatteryGuns
-import Geometry
-import ShapePicture
-import Shape
-import Dodge.Base
-import LensHelp
-import qualified IntMapHelp as IM
 
+import Dodge.Item.Held.BatteryGuns
+import Color
 import Data.List
 import Data.Maybe
+import Dodge.Base
+import Dodge.Data.GenWorld
+import Dodge.Default
+import Dodge.FloorItem
+import Dodge.LevelGen.Data
+import Dodge.Movement.Turn
+import Dodge.Wall.Delete
+import Dodge.WorldEvent.Explosion
+import Geometry
+import qualified IntMapHelp as IM
+import LensHelp
+import Shape
+import ShapePicture
 
 putLasTurret :: Float -> Placement
-putLasTurret rotSpeed = sps0 $ PutMachine (reverse $ square wdth) 
-    (defaultMachine 
-        & mcColor .~ blue
-        & mcDraw .~ MachineDrawTurret
-        & mcType .~ (lasTurret & tuTurnSpeed .~ rotSpeed)
-        & mcHP .~ 50000
-    )
-    defaultMachineWall
+putLasTurret rotSpeed =
+    sps0 $
+        PutMachine
+            (reverse $ square wdth)
+            ( defaultMachine
+                & mcColor .~ blue
+                & mcDraw .~ MachineDrawTurret
+                & mcType .~ (lasTurret & tuTurnSpeed .~ rotSpeed)
+                & mcHP .~ 50000
+            )
+            defaultMachineWall
+
 lasTurret :: MachineType
-lasTurret = Turret
-    { _tuWeapon = lasGun
---    { _tuWeapon = autoRifle
-    , _tuTurnSpeed = 0.1
-    , _tuFireTime = 0
-    , _tuMCrID = Nothing
-    }
+lasTurret =
+    Turret
+        { _tuWeapon = lasGun
+        , --    { _tuWeapon = autoRifle
+          _tuTurnSpeed = 0.1
+        , _tuFireTime = 0
+        , _tuMCrID = Nothing
+        }
 
 -- this needs a major cleanup
 updateTurret :: Float -> Machine -> World -> World
-updateTurret rotSpeed mc w 
-    | _mcHP mc < 1 = w & cWorld . machines %~ IM.delete mcid
-        & deleteWallIDs (_mcWallIDs mc)
-        & makeExplosionAt mcpos
-        & copyItemToFloor mcpos lasGun
-        & deleteHomonculus
-    | otherwise = w 
-        & initHomonculus
-        & dodamage 
-        & maybeFire 
-        & elecDamBranch
+updateTurret rotSpeed mc w
+    | _mcHP mc < 1 =
+        w & cWorld . machines %~ IM.delete mcid
+            & deleteWallIDs (_mcWallIDs mc)
+            & makeExplosionAt mcpos
+            & copyItemToFloor mcpos lasGun
+            & deleteHomonculus
+    | otherwise =
+        w
+            & initHomonculus
+            & dodamage
+            & maybeFire
+            & elecDamBranch
   where
     deleteHomonculus = case _tuMCrID (_mcType mc) of
         Nothing -> id
         Just cid -> cWorld . creatures . at cid .~ Nothing
     initHomonculus w' = case w' ^? cWorld . machines . ix mcid . mcType . tuMCrID . _Just of
-        Nothing -> w' & cWorld . machines . ix mcid . mcType . tuMCrID ?~ cid
-            & cWorld . creatures . at cid ?~ thecreature
+        Nothing ->
+            w' & cWorld . machines . ix mcid . mcType . tuMCrID ?~ cid
+                & cWorld . creatures . at cid ?~ thecreature
           where
             cid = IM.newKey (_creatures (_cWorld w'))
-            thecreature = defaultCreature
-                & crID .~ cid
-                & crInv . at 0 ?~ (_tuWeapon (_mcType mc) & itUse . useAim . aimHandlePos -~ 10
-                    & itUse . heldConsumption . laLoaded .~ 1
-                    )
-                & crPos .~ mcpos
-                & crOldPos .~ mcpos
-                & crRad    .~ 1
-                & crDir .~ mcdir
-                & crStance . posture .~ Aiming
-                & crMaterial .~ Crystal
-        Just cid -> w'
-            & cWorld . creatures . ix cid . crPos .~ mcpos
-            & cWorld . creatures . ix cid . crDir .~ mcdir
-    dodamage = cWorld . machines . ix mcid %~ 
-        ( (mcDamage .~ [Damage ELECTRICAL (min 2500 $ max 0 (elecDam - 10)) 0 0 0 NoDamageEffect])
-        . (mcHP -~ dam)
-        )
+            thecreature =
+                defaultCreature
+                    & crID .~ cid
+                    & crInv . at 0
+                        ?~ ( _tuWeapon (_mcType mc) & itUse . heldAim . aimHandlePos -~ 10
+                                & itUse . heldConsumption . laLoaded .~ 1
+                           )
+                    & crPos .~ mcpos
+                    & crOldPos .~ mcpos
+                    & crRad .~ 1
+                    & crDir .~ mcdir
+                    & crStance . posture .~ Aiming
+                    & crMaterial .~ Crystal
+        Just cid ->
+            w'
+                & cWorld . creatures . ix cid . crPos .~ mcpos
+                & cWorld . creatures . ix cid . crDir .~ mcdir
+    dodamage =
+        cWorld . machines . ix mcid
+            %~ ( (mcDamage .~ [Damage ELECTRICAL (min 2500 $ max 0 (elecDam - 10)) 0 0 0 NoDamageEffect])
+                    . (mcHP -~ dam)
+               )
     elecDamBranch
         | elecDam < 10 = updateFiringStatus . doTurn
         | otherwise = id
     maybeFire
-        | _tuFireTime (_mcType mc) > 0
-            = fromMaybe id $ do
+        | _tuFireTime (_mcType mc) > 0 =
+            fromMaybe id $ do
                 cid <- _tuMCrID (_mcType mc)
                 return $ cWorld . creatures . ix cid . crActionPlan . apImpulse .~ [UseItem]
         | otherwise = id
@@ -93,19 +105,20 @@ updateTurret rotSpeed mc w
     (elecDams, dams) = partition isElectrical $ _mcDamage mc
     dam = sum $ map _dmAmount dams
     elecDam = sum $ map _dmAmount elecDams
-    doTurn  
+    doTurn
         | seesYou = cWorld . machines . ix mcid . mcDir %~ turnTo rotSpeed mcpos ypos
         | otherwise = id
     closeFireAngle = seesYou -- && angleVV (ypos -.- mcpos) (unitVectorAtAngle mcdir) < 1
-    updateFiringStatus 
+    updateFiringStatus
         | closeFireAngle = cWorld . machines . ix mcid . mcType . tuFireTime .~ 20
-        | otherwise      = cWorld . machines . ix mcid . mcType . tuFireTime %~ (max 0 . subtract 1)
-    
+        | otherwise = cWorld . machines . ix mcid . mcType . tuFireTime %~ (max 0 . subtract 1)
 
 drawTurret :: Machine -> SPic
-drawTurret mc = (rotateSH (-_mcDir mc) . colorSH (_mcColor mc) $ upperPrismPoly 20 (square wdth)
+drawTurret mc =
+    ( rotateSH (- _mcDir mc) . colorSH (_mcColor mc) $ upperPrismPoly 20 (square wdth)
     , mempty -- setLayer 5 $ scale 0.5 0.5 $ text $ show $ _mcDir mc )
     )
+
 --    <> translateSPz 20 (itSPic it)
 --  where
 --    it = _tuWeapon $ _mcType mc

src/Dodge/Placement/Instance/Wall.hs

@@ -1,38 +1,40 @@
-module Dodge.Placement.Instance.Wall
-    where
-import Dodge.Data
-import Dodge.Placement.Instance.Block
-import Dodge.Default.Block
---import Dodge.Block.Debris
-import Dodge.LevelGen.Data
-import Dodge.Default.Wall
-import Geometry
-import Color
+module Dodge.Placement.Instance.Wall where
 
-import Data.List
+import Color
 import Control.Lens
+import Data.List
+import Dodge.Data.GenWorld
+import Dodge.Default.Block
+import Dodge.Default.Wall
+import Dodge.LevelGen.Data
+import Dodge.Placement.Instance.Block
+import Geometry
 
 heightWallPS :: PlacementSpot -> Float -> [Point2] -> Placement
 heightWallPS spot h ps = spNoID spot $ lowBlock Stone (_wlColor defaultWall) h ps
 
 invisibleWall :: [Point2] -> Placement
-invisibleWall ps = sps0 $ PutWall ps $ defaultWall
-    { _wlOpacity = SeeAbove
-    , _wlUnshadowed = False
-    , _wlHeight = 0
-    , _wlTouchThrough = True
-    }
+invisibleWall ps =
+    sps0 $
+        PutWall ps $
+            defaultWall
+                { _wlOpacity = SeeAbove
+                , _wlUnshadowed = False
+                , _wlHeight = 0
+                , _wlTouchThrough = True
+                }
 
 midWall :: [Point2] -> Placement
 midWall = heightWallPS (PS 0 0) 50
 
 singleBlock :: Point2 -> [Placement]
-singleBlock a = 
-    [sPS a 0 
-        $ PutBlock defaultBlock baseBlockPane
-        $ reverse 
-        $ square 10
+singleBlock a =
+    [ sPS a 0 $
+        PutBlock defaultBlock baseBlockPane $
+            reverse $
+                square 10
     ]
+
 {-
 Places a line of blocks between two points.
  -}
@@ -45,15 +47,17 @@ Width 8, also extends out from each point by 8.
  -}
 windowLine :: Point2 -> Point2 -> Placement
 windowLine a b = sps0 $ PutLineBlock defaultWindow 8 a b
+
 {-
 Places an unbreakable window between two points.
 Width 7, also extends out from each point by 7.
  -}
 crystalLine :: Point2 -> Point2 -> Placement
 crystalLine a b = sps0 $ PutLineBlock defaultCrystalWall 7 a b
+
 --crystalLine a b = sps0 $ PutWall ps defaultCrystalWall
 --  where
---    ps = 
+--    ps =
 --        [ a +.+ left +.+ up
 --        , (a +.+ left) -.- up
 --        , (b -.- left) -.- up
@@ -67,63 +71,74 @@ Depth 15, does not extend wider than points.
 wallLine :: Point2 -> Point2 -> Placement
 wallLine a b = sps0 $ PutWall ps defaultWall
   where
-    ps = [ a  +.+ up
-        , a  -.- up
-        , b  -.- up
-        , b  +.+ up
+    ps =
+        [ a +.+ up
+        , a -.- up
+        , b -.- up
+        , b +.+ up
         ]
-    left = 15 *.* normalizeV (a-.-b)
-    up   = vNormal left
+    left = 15 *.* normalizeV (a -.- b)
+    up = vNormal left
 
 windowLineType :: Point2 -> Point2 -> PSType
 windowLineType = PutLineBlock defaultWindow 8
 
 baseBlockPane :: Wall
-baseBlockPane = defaultWall
-    { _wlLine = (V2 0 0,V2 50 0)
-    , _wlID = 0
-    , _wlColor = greyN 0.5
-    , _wlSeen = False
-    , _wlOpacity = Opaque
-    , _wlUnshadowed = True
-    , _wlFireThrough = True
-    , _wlPenetrable  = True
-    }
+baseBlockPane =
+    defaultWall
+        { _wlLine = (V2 0 0, V2 50 0)
+        , _wlID = 0
+        , _wlColor = greyN 0.5
+        , _wlSeen = False
+        , _wlOpacity = Opaque
+        , _wlUnshadowed = True
+        , _wlFireThrough = True
+        , _wlPenetrable = True
+        }
+
 -- TODO find home for this
 {- Replaces instances of a given 'PutID' with 'PSType's drawn from a list.  -}
-replacePutID 
-    :: Int      -- ^ The id of 'PutID' to be replaced
-    -> [PSType] -- ^ List of replacements
-    -> Room 
-    -> Room
+replacePutID ::
+    -- | The id of 'PutID' to be replaced
+    Int ->
+    -- | List of replacements
+    [PSType] ->
+    Room ->
+    Room
 replacePutID i psts r =
     r & rmPmnts %~ flip (subZipWith (isPutID i) (\ps pt -> ps & plType .~ pt)) psts
-{- Partition a list by a predicate, apply a zip to those elements 
-that satisfy the predicate, concatenate 
+
+{- Partition a list by a predicate, apply a zip to those elements
+that satisfy the predicate, concatenate
 the new zipped list and the other (unchanged) half.  -}
-subZipWith 
-    :: (a -> Bool)      -- ^ Filter: elements to apply zip to
-    -> (a -> b -> a)    -- ^ Combining function
-    -> [a]              -- ^ List to be partitioned
-    -> [b]              -- ^ Modifying list
-    -> [a]
+subZipWith ::
+    -- | Filter: elements to apply zip to
+    (a -> Bool) ->
+    -- | Combining function
+    (a -> b -> a) ->
+    -- | List to be partitioned
+    [a] ->
+    -- | Modifying list
+    [b] ->
+    [a]
 subZipWith f g xs ys =
-    let (zs,ws) = partition f xs
-    in  zipWith g zs ys ++ ws
+    let (zs, ws) = partition f xs
+     in zipWith g zs ys ++ ws
 
 isPutID :: Int -> Placement -> Bool
 isPutID i ps = Just i == ps ^? plType . putID
 
 putBlockRect' :: Float -> Float -> Placement
-putBlockRect' w h = ps0jPushPS (aline tl tr)
-    $ ps0jPushPS (aline tr br)
-    $ ps0jPushPS (aline br bl)
-    $ sps0 (aline bl tl)
+putBlockRect' w h =
+    ps0jPushPS (aline tl tr) $
+        ps0jPushPS (aline tr br) $
+            ps0jPushPS (aline br bl) $
+                sps0 (aline bl tl)
   where
-    tl = V2 (-w) h
+    tl = V2 (- w) h
     tr = V2 w h
-    br = V2 w (-h)
-    bl = V2 (-w) (-h)
+    br = V2 w (- h)
+    bl = V2 (- w) (- h)
     aline = PutLineBlock baseBlockPane 9
 
 putBlockRect :: Float -> Float -> Float -> Float -> [Placement]
@@ -133,19 +148,22 @@ putBlockRect a x b y =
     , blockLine (V2 x y) (V2 x b)
     , blockLine (V2 x b) (V2 a b)
     ]
+
 putBlockV :: Float -> Float -> Float -> Float -> [Placement]
-putBlockV a x b y = 
+putBlockV a x b y =
     [ blockLine (V2 a b) (V2 a y)
     , blockLine (V2 x b) (V2 a b)
     ]
+
 putBlockC :: Float -> Float -> Float -> Float -> [Placement]
-putBlockC a x b y = 
+putBlockC a x b y =
     [ blockLine (V2 a b) (V2 a y)
     , blockLine (V2 x b) (V2 a b)
     , blockLine (V2 a y) (V2 x y)
     ]
+
 putBlockN :: Float -> Float -> Float -> Float -> [Placement]
-putBlockN a x b y = 
+putBlockN a x b y =
     [ blockLine (V2 a b) (V2 a y)
     , blockLine (V2 x b) (V2 a b)
     , blockLine (V2 x y) (V2 x b)