Add support for clamping pictures to be inside screen

src/Dodge/Base/Window.hs

@@ -5,6 +5,7 @@ import Dodge.Data
 import Dodge.Config.Data
 import Geometry
 
+-- | A box covering the screen in world coordinates
 screenPolygon :: World -> [Point2]
 screenPolygon w = [tr,tl,bl,br]
   where 
@@ -17,9 +18,36 @@ screenPolygon w = [tr,tl,bl,br]
     br = scTran $ scRot $ scZoom (V2 ( halfWidth w) (-halfHeight w))
     bl = scTran $ scRot $ scZoom (V2 (-halfWidth w) (-halfHeight w))
 
+-- | A box covering the screen in world coordinates, with a x and y border
+screenPolygonBord 
+    :: Float    -- ^ X border
+    -> Float    -- ^ Y border
+    -> World
+    -> [Point2]
+screenPolygonBord xbord ybord w = [tr,tl,bl,br]
+  where 
+    hw = halfWidth  w - xbord
+    hh = halfHeight w - ybord
+    scZoom p | _cameraZoom w /= 0   = (1/_cameraZoom w) *.* p
+             | otherwise            = p
+    theTransform = (+.+ _cameraCenter w) . rotateV (_cameraRot w) . scZoom
+    tr = theTransform (V2   hw    hh ) 
+    tl = theTransform (V2 (-hw)   hh ) 
+    br = theTransform (V2   hw  (-hh))
+    bl = theTransform (V2 (-hw) (-hh))
+
 halfWidth,halfHeight :: World -> Float
 halfWidth w = getWindowX w / 2
 halfHeight w = getWindowY w / 2
 getWindowX ,getWindowY :: World -> Float 
 getWindowX = _windowX . _config
 getWindowY = _windowY . _config
+
+-- | A box of the size of the screen in screen centered coordinates
+screenBox 
+    :: World
+    -> [Point2]
+screenBox w = rectNSEW hh (-hh) hw (-hw)
+  where
+    hw = halfWidth w
+    hh = halfHeight w

src/Dodge/Menu.hs

@@ -12,7 +12,7 @@ import Preload.Update
 import Dodge.Base.Window
 import Dodge.SoundLogic
 import Picture
-import Geometry
+--import Geometry
 
 import Control.Lens
 import Data.Maybe
@@ -193,10 +193,3 @@ controlsList = pictures $ concat $ zipWith butAndEff
         ,translate     0  y $ scale 0.15 0.15 $ color white $ text etext
         ]
 
-screenBox 
-    :: World
-    -> [Point2]
-screenBox w = rectNSEW hh (-hh) hw (-hw)
-  where
-    hw = halfWidth w
-    hh = halfHeight w

src/Dodge/Render/Picture.hs

@@ -6,6 +6,7 @@ import Dodge.Base
 import Dodge.Base.Window
 import Dodge.Base.Zone
 import Dodge.Picture
+import Dodge.Picture.SizeInvariant
 import Dodge.Picture.Layer
 import Dodge.Render.HUD
 import Dodge.Render.MenuScreen
@@ -18,6 +19,7 @@ import Control.Lens
 import Data.Maybe
 import Data.List (partition)
 import qualified Data.IntMap.Lazy as IM
+import qualified Data.Map as M
 
 worldPictures :: World -> Picture
 worldPictures w = pictures
@@ -59,9 +61,24 @@ customMouseCursor w =
     $ pictures [ line [V2 (-5) 0,V2 5 0] , line [V2 0 (-5),V2 0 5] ]
 
 testPic :: World -> Picture
-testPic _ = blank
+testPic w = pictures 
+    [ soundPics w
+--    , fixedSizePicClampArrow 10 50 thepic (mouseWorldPos w) w
+    ]
+--  where
+--    thepic = setDepth 20 . color green . polygon $ rectNSEW 5 (-5) (-5) (5)
+--testPic _ = blank
 --testPic w = color green . pictures . map (flip thickLine 5 . tflat2) . graphToEdges $ _pathGraph w
 
+soundPics :: World -> Picture
+soundPics w = pictures $ M.map (soundPic w) $ _playingSounds w
+
+soundPic :: World -> Sound -> Picture
+soundPic w s = fixedSizePicClampArrow 50 50 thePic p w
+  where
+    p = _soundPos s
+    thePic = scale 0.15 0.15 $ text "SOUND"
+
 crDraw :: World -> Creature -> Picture
 crDraw w c = _crPict c c w
 ppDraw :: PressPlate -> Picture

src/Geometry/Intersect.hs

@@ -178,3 +178,11 @@ intersectSegsSeg = undefined
 -- | Placeholder: should intersect a segment with a bezier curve.
 intersectSegBezquad :: Point2 -> Point2 -> Point2 -> Point2 -> Point2 -> [Point2]
 intersectSegBezquad = undefined
+
+-- | finds one (if any) of the points of intersection between a segment and a
+-- polygon.
+-- Can almost certainly be optimised.
+intersectSegPolyFirst :: Point2 -> Point2 -> [Point2] -> Maybe Point2
+intersectSegPolyFirst a b xs = foldr (<|>) Nothing $ zipWith lineColl xs (tail xs ++ [head xs])
+  where
+    lineColl = intersectSegSeg a b