Unify world shape and picture into spic

src/Dodge/Render/ShapePicture.hs

@@ -1,16 +1,108 @@
 module Dodge.Render.ShapePicture
     ( floorItemSPic
+    , worldSPic
     )
     where
+import Dodge.Config.Data
+--import Dodge.Debug.Picture
+import Dodge.Picture.SizeInvariant
 import Dodge.Data
+import Dodge.Base
+import Dodge.Base.Window
+import Dodge.SoundLogic.LoadSound
+import Dodge.Graph
+import Dodge.GameRoom
+import Dodge.Update.Camera
 import Geometry
 import ShapePicture
---import Shape
---import Picture
+import Shape
+import Picture
+import Sound.Data
+
+import qualified Data.IntMap.Strict as IM
+import qualified Data.Map.Strict as M
+
+worldSPic :: World -> SPic
+worldSPic w = 
+    (extraShapes w, extraPics w)
+    <> foldMap (dbArg _prDraw) (filtOn _pjPos _props)
+    <> foldMap (($ w) . dbArg _crPict) (filtOn _crPos _creatures)
+    <> foldMap floorItemSPic (filtOn _flItPos _floorItems)
+    <> foldMap btSPic (filtOn _btPos _buttons)
+    <> foldMap mcSPic (filtOn _mcPos _machines)
+  where
+    filtOn f g = IM.filter (pointIsClose . f) (g w)
+    pointIsClose p = dist camCen p < winSize
+    winSize = 30 + max (getWindowX w) (getWindowY w)
+    camCen = _cameraCenter w
+
+extraShapes :: World -> Shape
+extraShapes w = _foregroundShape w
+
+extraPics :: World -> Picture
+extraPics w = pictures (_decorations w)
+    <> concatMapPic (dbArg _ptDraw) (_particles    w)
+    <> concatMapPic (dbArg _lsPict) (_lightSources w)
+    <> testPic w
+    <> concatMapPic clDraw (_clouds w      )
+    <> concatMapPic ppDraw (_pressPlates w )
+    <> soundPics w
+    <> viewBoundaries w
+    <> drawPathing w
+
+-- TODO remove duplicate!
+testPic :: World -> Picture
+testPic _ = []
+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) 
+floorItemSPic flit = uncurryV translateSPf (_flItPos flit) 
     $ rotateSP (_flItRot flit)  (_itFloorPict (_flIt flit) (_flIt flit))
 
---TODO combine worldShape and worldPicture here
+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)
+
+soundPics :: World -> Picture
+soundPics w 
+    | _show_sound (_config w) = pictures $ M.map (soundPic w) $ _playingSounds w
+    | otherwise = []
+
+soundPic :: World -> Sound -> Picture
+soundPic w s = fixedSizePicClampArrow 50 50 thePic p 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)
+
+drawPathing :: World -> Picture
+drawPathing w
+    | _debug_pathing (_config w) 
+        = -- setLayer 5 $ 
+        (color green . pictures . map (flip thickLine 5 . tflat2) $ graphToEdges gr)
+        <> concatMap dispInc (graphToIncidence gr)
+    | otherwise = []
+  where
+    dispInc (p,n) = setDepth 2 . uncurryV translate p . scale 0.1 0.1 $ text $ show n
+    gr = _pathGraph w
+viewBoundaries :: World -> Picture
+viewBoundaries w
+    | _debug_view_boundaries (_config w) 
+        = setLayer 5 $ color green (concatMap (polygonWire . _grBound) grs)
+        <> color yellow (concatMap (\q -> line [p,q]) $ farWallPoints p w)
+    | otherwise = []
+  where
+    p = _crPos $ you w
+    grs = filter (pointInOrOnPolygon p . _grBound) (_gameRooms w)