Abstract out block placement

src/Bound.hs

@@ -0,0 +1,17 @@
+module Bound where
+import Geometry
+
+import Control.Lens
+import Streaming
+import qualified Streaming.Prelude as S
+import qualified Control.Foldl as L
+
+boundPoints :: Stream (Of Point2) Identity () -> Maybe (Float,Float,Float,Float)
+boundPoints = f . runIdentity . L.purely S.fold_ ((,,,) 
+    <$> L.premap (^?! _2) L.maximum
+    <*> L.premap (^?! _2) L.minimum
+    <*> L.premap (^?! _1) L.maximum
+    <*> L.premap (^?! _1) L.minimum
+    )
+  where
+    f (mn,ms,me,mw) = (,,,) <$> mn <*> ms <*> me <*> mw

src/Dodge/Base/Collide.hs

@@ -96,6 +96,7 @@ collidePointWallsFilterStream t sp ep = collidePoint sp ep
     . S.filter t
     . wallsAlongLine sp ep
 
+-- this hopefully also nub the stream in most cases
 --orderStreamOn :: Ord b => (a -> b) -> Stream (Of a) Identity () -> Identity (Of (M.Map b a) ())
 sortStreamOn :: Ord a => (b -> a) -> Stream (Of b) Identity () -> Stream (Of b) Identity ()
 {-# INLINE sortStreamOn #-}

src/Dodge/Data.hs

@@ -13,6 +13,7 @@ module Dodge.Data
     , module Dodge.Data.LoadAction
     , module Dodge.Data.ForegroundShape
     , module Dodge.Data.Wall
+    , module Dodge.Data.Bounds
     , module Dodge.Combine.Data
     , module Dodge.Distortion.Data
     , module Dodge.Data.DamageType
@@ -35,6 +36,7 @@ import Dodge.Data.ForegroundShape
 import Dodge.Data.LoadAction
 import Dodge.Data.Material
 import Dodge.Data.Wall
+import Dodge.Data.Bounds
 import Dodge.RoomCluster.Data
 import Dodge.Data.ItemAmount
 import Dodge.ShortShow
@@ -51,7 +53,6 @@ import Dodge.Config.Data
 import Dodge.Config.KeyConfig
 import Dodge.Item.Attachment.Data
 import Dodge.Item.Data
-import Dodge.Bounds
 import Data.Preload
 import Picture.Data
 import ShapePicture

src/Dodge/Data/Bounds.hs

@@ -1,6 +1,6 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE StrictData #-}
-module Dodge.Bounds
+module Dodge.Data.Bounds
     where
 import Control.Lens
 

src/Dodge/Default/World.hs

@@ -2,7 +2,6 @@ module Dodge.Default.World where
 import Dodge.Data
 import Dodge.Base
 --import Dodge.Config.KeyConfig
-import Dodge.Bounds
 --import Dodge.Menu
 --import Picture
 import Geometry.Data

src/Dodge/Floor.hs

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

src/Dodge/Layout.hs

@@ -13,7 +13,6 @@ import Dodge.LevelGen.LevelStructure
 import Dodge.Room.Foreground
 import Dodge.Wall.Zone
 import Dodge.GameRoom
-import Dodge.Bounds
 import Dodge.Default.Wall
 import Dodge.Room.Link
 import Dodge.Randify

src/Dodge/Placement/Instance/Block.hs

@@ -0,0 +1,23 @@
+module Dodge.Placement.Instance.Block where
+import Dodge.Data
+import Geometry
+import Color
+import LensHelp
+import ShapePicture
+import Shape
+import Dodge.Default.Wall
+import Dodge.Default.Block
+
+lowBlock :: Material -> Color -> Float -> [Point2] -> PSType
+lowBlock mat col h ps = PutBlock bl wl $ reverse ps
+  where
+    bl = defaultBlock
+        & blDraw .~ const (noPic $ colorSH col (upperPrismPoly h $ reverse ps))
+        & blDeath .~ const id
+    wl = defaultWall 
+        & wlDraw .~ False 
+        & wlColor .~ col 
+        & wlRotateTo .~ False  
+        & wlOpacity .~ SeeAbove
+        & wlMaterial .~ mat
+        & wlHeight .~ h

src/Dodge/Placement/Instance/Wall.hs

@@ -1,6 +1,7 @@
 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
@@ -14,26 +15,7 @@ import Data.List
 import Control.Lens
 
 heightWallPS :: PlacementSpot -> Float -> [Point2] -> Placement
-heightWallPS spot h ps = psj spot (PutShape . colorSH col $ upperPrismPoly h ps)
-    $ sps spot $ PutWall ps theWall
-  where
-    col = _wlColor defaultWall
-    theWall = defaultWall
-        { _wlOpacity = SeeAbove
-        , _wlDraw = False
-        , _wlHeight = h
-        }
-
-heightWall :: Float -> [Point2] -> Placement
-heightWall h ps = ps0j (PutShape . colorSH col $ upperPrismPoly h ps)
-    $ sps0 $ PutWall ps theWall
-  where
-    col = _wlColor defaultWall
-    theWall = defaultWall
-        { _wlOpacity = SeeAbove
-        , _wlDraw = False
-        , _wlHeight = h
-        }
+heightWallPS spot h ps = spNoID spot $ lowBlock Stone (_wlColor defaultWall) h ps
 
 invisibleWall :: [Point2] -> Placement
 invisibleWall ps = sps0 $ PutWall ps $ defaultWall

src/Dodge/Room/Airlock.hs

@@ -31,7 +31,7 @@ airlock0 = defaultRoom
                 $ \_ _ -> Just $ putDoubleDoor thewall (cond' btid) (V2 0 80) (V2 40 80) 2
         , invisibleWall $ rectNSWE 60 40 (-40) (-30)
         ,spanLightI (V2 (-2) 30) (V2 (-2) 70)
-        ,sps0 $ PutShape $ thinHighBar 75 (V2 40 50) (V2 (-1) 50)
+        ,sps0 $ putShape $ thinHighBar 75 (V2 40 50) (V2 (-1) 50)
         ]
     , _rmBound = [rectNSWE 75 15 0 40,switchcut]
     }

src/Dodge/Room/Foreground.hs

@@ -1,11 +1,12 @@
 --{-# LANGUAGE TupleSections #-}
 module Dodge.Room.Foreground where
+import Dodge.Data
 import Picture
 import Geometry
 import Shape
 import Quaternion
 
-import Dodge.Data.ForegroundShape
+--import Dodge.Data.ForegroundShape
 import Dodge.Default.Foreground
 import Data.List
 import Data.Maybe
@@ -115,6 +116,24 @@ girderVCapLR csize h d w x y = thinHighBar h (x -.- n) (x +.+ n)
   where
     n = csize *.* vNormal (normalizeV (x -.- y))
 
+putShape :: Shape -> PSType
+putShape sh = PutForeground $ defaultForeground
+    & fsPos .~ m
+    & fsRad .~ radBounds bnds
+    & fsSPic .~ noPic (uncurryV translateSHf (-m) $ sh)
+  where
+    bnds = shapeBounds sh
+    m = midBounds bnds
+
+shapeBounds :: Shape -> (Float,Float,Float,Float)
+shapeBounds sh = undefined
+
+midBounds :: (Float,Float,Float,Float) -> Point2
+midBounds (n,s,e,w) = V2 ((n + s)/2) ((e + w)/2)
+
+radBounds :: (Float, Float,Float,Float) -> Float
+radBounds (n,s,e,w) = max (n-s) (e-w) / 2
+
 girderV'
     :: Float -- ^ "cap" size
     -> Float -- ^ height
@@ -123,7 +142,7 @@ girderV'
     -> Point2 -> Point2 -> ForegroundShape
 girderV' csize h d w x y = defaultForeground
     & fsPos .~ m
-    & fsRad .~ dist m x'
+    & fsRad .~ dist m x
     & fsSPic .~ noPic sh
   where
     m = midPoint x y

src/Dodge/Room/LasTurret.hs

@@ -10,24 +10,15 @@ 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.Room.Foreground
+import Dodge.Wire
 import Dodge.Placement.Instance
 import Dodge.Placement.Instance.Analyser
 import Dodge.Default.Room
 import Dodge.Item.Consumable
---import Dodge.Machine
---import Dodge.Item.Weapon.Utility
---import Dodge.LevelGen.Data
---import Geometry.Data
 import Geometry
---import Padding
-import Color
-import Shape
 import LensHelp
 import RandomHelp
---import Dodge.SoundLogic
 
 import qualified Data.Set as S
 import Data.Maybe
@@ -39,15 +30,15 @@ cenLasTur = roomNgon 8 200 & rmPmnts .~
     , mntLightLnkCond $ rprBool $ const . isInLnk
     ]
   where
-    covershape = reverse $ rectNSWE 10 (-10) (-20) 20
+    covershape = rectNSWE 10 (-10) (-20) 20
 
 lightSensInsideDoor :: Int -> Room -> Room
 lightSensInsideDoor outplid rm = rm 
-    & rmPmnts .:~ psPt atFstLnkOut 
-        (PutShape $ colorSH yellow $
-        thinHighBar 0 (V2 20 (-1)) (V2 20 (-100))
-        <> thinHighBar 0 (V2 0 (-100)) (V2 20 (-100))
-        <> barPP 1.5 (V3 20 (-1) 0) (V3 20 (-1) 80))
+    & rmPmnts .++~ 
+        [ psPt atFstLnkOut (PutForeground $ floorWire (V2 20 0) (V2 20 (-100)))
+        , psPt atFstLnkOut (PutForeground $ floorWire (V2 0 (-100)) (V2 20 (-100)))
+        , psPt atFstLnkOut (PutForeground $ verticalWire (V2 20 0) 0 80)
+        ]
     & rmOutPmnt .~ [OutPlacement (lasSensLightAboveDoor 10 (atFstLnkOutShiftInward 100)) outplid]
 
 lasSensLightAboveDoor :: Float -> PlacementSpot -> Placement
@@ -61,14 +52,13 @@ lasSensLightAboveDoor wth ps = extTrigLitPos
 lightSensByDoor :: Int -> Room -> Room
 lightSensByDoor outplid rm = rm
     & rmPmnts .++~ 
-        [ psPt atFstLnkOut $ PutShape $ colorSH yellow 
-            $ barPP 1.5 (V3 20 (-1) 0) (V3 20 (-1) 80)
+        [ psPt atFstLnkOut $ PutForeground $ verticalWire (V2 20 0) 0 80
         , heightWallPS (atNthLnkOutShiftInward 1 100) 30 covershape
         , heightWallPS (atFstLnkOutShiftInward 100)   30 covershape
         ]
     & rmOutPmnt .~ [OutPlacement (lasSensLightAboveDoor 20 (atFstLnkOutShiftBy sensorshift)) outplid]
   where
-    covershape = reverse $ rectNSWE 10 (-10) (-20) 20
+    covershape = rectNSWE 10 (-10) (-20) 20
     sensorshift (p,a) = (p +.+ rotateV a (V2 60 (-20)), a)
 
 keyCardRoomRunPast :: RandomGen g => Int -> Int -> State g (MetaTree Room String)
@@ -90,8 +80,7 @@ healthAnalyserByDoor = analyserByDoor (RequireHealth 1100)
 analyserByDoor :: ProximityRequirement -> Int -> Room -> Room
 analyserByDoor proxreq outplid rm = rm 
     & rmPmnts .++~ 
-        [ psPt atFstLnkOut $ PutShape $ colorSH yellow 
-            $ barPP 1.5 (V3 20 (-1) 0) (V3 20 (-1) 80)
+        [ psPt atFstLnkOut $ PutForeground $ verticalWire (V2 20 0) 0 80
         ]
     & rmOutPmnt .~ 
         [OutPlacement 

src/Dodge/Room/SensorDoor.hs

@@ -8,6 +8,7 @@ import Dodge.Placement.Instance.Terminal
 import Dodge.Terminal
 import Dodge.Data
 import Dodge.Tree
+import Dodge.Wire
 --import Dodge.RoomLink
 import Dodge.Room.Door
 import Dodge.Room.Ngon
@@ -80,11 +81,9 @@ sensInsideDoor :: DamageType -> Int -> Room -> Room
 sensInsideDoor senseType outplid rm = rm
     & rmName .++~ take 4 (show senseType)
     & rmPmnts .++~ 
-        [ psPt atFstLnkOut 
-            (PutShape $ colorSH yellow $
-            thinHighBar 0 (V2 20 (-1)) (V2 20 (-100))
-            <> thinHighBar 0 (V2 0 (-100)) (V2 20 (-100))
-            <> barPP 1.5 (V3 20 (-1) 0) (V3 20 (-1) 80))
+        [ psPt atFstLnkOut . PutForeground $ floorWire (V2 20 0) (V2 20 (-100))
+        , psPt atFstLnkOut . PutForeground $ floorWire (V2 0 (-100)) (V2 20 (-100))
+        , psPt atFstLnkOut . PutForeground $ verticalWire (V2 20 0) 0 80
         , putTerminal terminalColor (basicTerminal & tmScrollCommands .:~ damageCodeCommand)
             & plSpot .~ rprBoolShift isUnusedLnk (shiftInBy 10)
         ]

src/Dodge/Wire.hs

@@ -1,10 +1,30 @@
 module Dodge.Wire where
 --import Dodge.LevelGen.Data
+import Dodge.Default.Foreground
 import Dodge.Data
 import Geometry
+import LensHelp
+import ShapePicture
+import Shape
+import Color
+import Dodge.Room.Foreground
 
 import qualified Data.IntMap.Strict as IM
-import Control.Lens
+
+floorWire :: Point2 -> Point2 -> ForegroundShape
+floorWire a b = defaultForeground
+    & fsPos .~ m
+    & fsRad .~ dist m a
+    & fsSPic .~ noPic (colorSH yellow $ thinHighBar 0 a' b')
+  where
+    m = midPoint a b
+    a' = a - m
+    b' = b - m
+verticalWire :: Point2 -> Float -> Float -> ForegroundShape
+verticalWire p h1 h2 = defaultForeground
+    & fsPos .~ p
+    & fsRad .~ 2
+    & fsSPic .~ noPic (colorSH yellow $ barPP 1.5 (V3 0 0 h1) (V3 0 0 h2))
 
 putWireEnd :: Int -> (Point2,Float) -> Float -> Room -> Room
 putWireEnd i (p,a) h = rmEndWires %~ IM.insert i (WallWire p a h)