Work out screen coordinates for connecting infobox

src/Dodge/Creature/Picture.hs

@@ -13,7 +13,7 @@ module Dodge.Creature.Picture
 import Dodge.Data
 --import Dodge.Base
 import Dodge.Creature.Test
---import Dodge.Render.InfoBox
+import Dodge.Render.InfoBox
 import Dodge.Render.List
 --import Dodge.Creature.AlertLevel.Data
 --import Dodge.Picture.Layer
@@ -87,17 +87,16 @@ crDisplayInfo cfig w cr = (_crPos cr,
     crOnScreen = pointOnScreen cfig w $ _crPos cr
 
 creatureDisplayText :: Configuration -> World -> Creature -> Picture
-creatureDisplayText cfig w cr = setLayer FixedCoordLayer . setDepth 50 
+creatureDisplayText cfig w cr 
-    $ color white $ renderListAt 0 0 cfig $ zip ["TEST","ME"] $ repeat white
+    = setLayer FixedCoordLayer $ renderInfoListAt 0 0 cfig w
-    -- $ renderInfoListAt 0 0 cfig w
+    $ crDisplayInfo cfig w cr
-    -- $ crDisplayInfo cfig w cr
 
 creatureDisplayText' :: Configuration -> World -> Creature -> Picture
 creatureDisplayText' cfig w cr 
   | not (_debug_cr_status cfig) = []
   | otherwise
-    = setLayer TopLayer 
+    = setLayer DebugLayer 
-    . setDepth 50 
+    . setDepth 20 
     . translate x y 
     . color white 
     . rotate (0.5 * pi)

src/Dodge/Debug/LinkDecoration.hs

@@ -25,11 +25,11 @@ roomLinkDecorations :: Room -> Picture
 roomLinkDecorations rm = pictures . map (linkDecoration . lnkPosDir) $ _rmLinks rm
 
 linkDecoration :: (Point2,Float) -> Picture
-linkDecoration (p,a) = setLayer TopLayer . setDepth 50 . color red $ line [p, p +.+ 20 *.* unitVectorAtAngle (a - pi/2)]
+linkDecoration (p,a) = setLayer DebugLayer . color red $ line [p, p +.+ 20 *.* unitVectorAtAngle (a - pi/2)]
 
 roomPolyDecorations :: Room -> Picture
 roomPolyDecorations rm = pictures . map polyWireFrame $ _rmPolys rm
 
 polyWireFrame :: [Point2] -> Picture
-polyWireFrame (x:xs) = setLayer TopLayer . setDepth 50 . color green $ line $ (x:xs) ++ [x]
+polyWireFrame (x:xs) = setLayer DebugLayer . setDepth 50 . color green $ line $ (x:xs) ++ [x]
 polyWireFrame _ = undefined

src/Dodge/Item/Weapon/ExtraEffect.hs

@@ -75,7 +75,7 @@ targetCursor = defaultTargeting
 targetSimpleDraw :: Int -> Item -> Creature -> World -> Picture
 targetSimpleDraw _ it _ w = fromMaybe mempty $ do
     mwp <- it ^? itTargeting . tgPos . _Just
-    return $ setLayer TopLayer $ color red $ setDepth 50 $ uncurryV translate mwp 
+    return $ setLayer DebugLayer $ color red $ setDepth 50 $ uncurryV translate mwp 
         $ rotate (_cameraRot w)
         $ pictures
             [line [V2   x  x, V2 (-x) (-x)]
@@ -87,7 +87,7 @@ targetSimpleDraw _ it _ w = fromMaybe mempty $ do
 targetRBCreatureDraw :: Int -> Item -> Creature -> World -> Picture
 targetRBCreatureDraw _ it _ w = fromMaybe mempty $ do
     mwp <- it ^? itTargeting . tgPos . _Just
-    return $ setLayer TopLayer $ color thecolor $ setDepth 50 $ uncurryV translate mwp 
+    return $ setLayer DebugLayer $ color thecolor $ setDepth 50 $ uncurryV translate mwp 
         $ rotate (_cameraRot w)
         $ pictures
             [line [V2   x  x, V2 (-x) (-x)]

src/Dodge/Picture/SizeInvariant.hs

@@ -14,8 +14,8 @@ fixedSizePicAt
     -> World
     -> Picture
 fixedSizePicAt pic p w 
-    = setLayer TopLayer 
+    = setLayer DebugLayer 
-    . setDepth 50 
+    . setDepth 20 
     . translate x y 
     . scale theScale theScale 
     $ pic 
@@ -34,8 +34,8 @@ fixedSizePicClamp
     -> World
     -> Picture
 fixedSizePicClamp xbord ybord pic p cfig w
-    = setLayer TopLayer 
+    = setLayer DebugLayer 
---    . setDepth 50 
+    . setDepth 20
     . translate x y 
     . scale theScale theScale 
     $ pic 
@@ -59,8 +59,8 @@ fixedSizePicClampArrow
     -> World
     -> Picture
 fixedSizePicClampArrow xbord ybord pic p cfig w = pictures 
-    [ setLayer TopLayer . translate x y . scale theScale theScale $ pic 
+    [ setLayer DebugLayer . translate x y . scale theScale theScale $ pic 
-    , setLayer TopLayer . color white . setDepth 20 $ arrowPic
+    , setLayer DebugLayer . color white . setDepth 20 $ arrowPic
     ]
   where
     winps = screenPolygon cfig w

src/Dodge/Render.hs

@@ -116,7 +116,7 @@ doDrawing pdata u = do
         then renderTextureWalls pdata nWalls
         else renderBlankWalls pdata nWalls
     --draw object pictures onto base buffer
-    renderLayer 0 shadV layerCounts
+    renderLayer BottomLayer shadV layerCounts
     --draw object shapes onto base buffer
     let fs = _shapeShader pdata
     currentProgram $= Just (_shadProg fs)
@@ -146,9 +146,9 @@ doDrawing pdata u = do
     depthFunc $= Just Less
     blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
     depthMask $= Disabled
-    renderLayer 3 shadV layerCounts
+    renderLayer BloomNoZWrite shadV layerCounts
     depthMask $= Enabled
-    renderLayer 1 shadV layerCounts
+    renderLayer BloomLayer shadV layerCounts
     --depthMask $= Enabled
     --setup downscale viewport for blurring bloom
     setViewportSize (round winx `div` (2*resFact)) (round winy `div` (2*resFact))
@@ -171,7 +171,7 @@ doDrawing pdata u = do
     blendFuncSeparate $= ((SrcAlpha,OneMinusSrcAlpha),(One,OneMinusSrcAlpha))
     drawBuffers $= [FBOColorAttachment 0,NoBuffers]
     clear [ColorBuffer]
-    renderLayer 2 shadV layerCounts
+    renderLayer MidLayer shadV layerCounts
     --renderWindows pdata windowPoints
     drawShader (_windowShader pdata) nWins
     when (_cloud_shadows cfig) $ do
@@ -179,7 +179,7 @@ doDrawing pdata u = do
         depthMask $= Enabled
         blend $= Disabled
         drawBuffers $= [NoBuffers,FBOColorAttachment 1]
-        renderLayer 2 shadV layerCounts
+        renderLayer MidLayer shadV layerCounts
         drawShader (_windowShader pdata) nWins
         ----draw lightmap for cloud buffer
         depthMask $= Disabled
@@ -237,14 +237,14 @@ doDrawing pdata u = do
     depthFunc $= Just Always
     blend $= Enabled
     blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
-    renderLayer 5 shadV layerCounts
+    renderLayer DebugLayer shadV layerCounts
     -- draw overlay
     depthFunc $= Just Always
     depthMask $= Disabled
     blend $= Enabled
     blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
-    renderLayer 4 shadV layerCounts
     bufferUBO $ isoMatrix 0 1 (V2 0 0) (V2 2 2)
+    renderLayer FixedCoordLayer shadV layerCounts
     renderFoldable shadV $ fixedCoordPictures u
     depthMask $= Enabled
     eTicks <- SDL.ticks

src/Dodge/Render/InfoBox.hs

@@ -4,7 +4,7 @@ import Dodge.Data
 --import Dodge.Base.WinScale
 import Dodge.Render.Connectors
 import Dodge.Render.List
-import Dodge.Base.Coordinate
+import Dodge.Base
 import Picture
 import Geometry
 --import Control.Monad
@@ -12,4 +12,7 @@ import Geometry
 
 renderInfoListAt :: Float -> Float -> Configuration -> World -> (Point2,[String]) -> Picture
 renderInfoListAt x y cfig w (p,ss) = renderListAt x y cfig (zip ss (repeat white))
-    <> zConnect (V2 x y) (worldPosToScreenNorm cfig w p)
+    <> winScale cfig (color yellow $ zConnect (V2 (20+x-hw) (y+hh-20)) (worldPosToScreen w p))
+  where
+    hw = halfWidth cfig
+    hh = halfHeight cfig

src/Dodge/Render/ShapePicture.hs

@@ -96,7 +96,7 @@ soundPic cfig w s = fixedSizePicClampArrow 50 50 thePic p cfig w
 drawPathing :: Configuration -> World -> Picture
 drawPathing cfig w
     | _debug_pathing cfig 
-        = -- setLayer 5 $ 
+        = setLayer DebugLayer $ 
         (color green . pictures . map (thickLine 5 . tflat2) $ graphToEdges gr)
         <> concatMap dispInc (graphToIncidence gr)
     | otherwise = []
@@ -106,7 +106,7 @@ drawPathing cfig w
 viewBoundaries :: Configuration -> World -> Picture
 viewBoundaries cfig w
     | _debug_view_boundaries cfig 
-        = setLayer TopLayer $ color green (concatMap (polygonWire . _grBound) grs)
+        = setLayer DebugLayer $ color green (concatMap (polygonWire . _grBound) grs)
         <> color yellow (concatMap (\q -> line [p,q]) $ farWallPoints p w)
     | otherwise = []
   where
@@ -116,9 +116,9 @@ viewBoundaries cfig w
 viewClipBounds :: Configuration -> World -> Picture
 viewClipBounds cfig w
     | _debug_view_clip_bounds cfig == AllRoomClipBoundaries
-         = setLayer TopLayer $ color green $ concatMap (polygonWire . _cpPoints) (_roomClipping w)
+         = setLayer DebugLayer $ color green $ concatMap (polygonWire . _cpPoints) (_roomClipping w)
     | _debug_view_clip_bounds cfig == IntersectingRoomClipBoundaries
-        = setLayer TopLayer $ f (_roomClipping w)
+        = setLayer DebugLayer $ f (_roomClipping w)
     | otherwise = []
   where
     f (x:xs) = g x xs <> f xs

src/Picture/Data.hs

@@ -20,20 +20,14 @@ data Layer
     | MidLayer
     | BloomLayer
     | BloomNoZWrite
-    | TopLayer
+    | DebugLayer
     | FixedCoordLayer
+  deriving (Eq,Ord,Enum,Bounded)
 
 layerNum :: Layer -> Int
-layerNum lay = case lay of
+layerNum = fromEnum
-    BottomLayer     -> 0
-    MidLayer        -> 1
-    BloomLayer      -> 2
-    BloomNoZWrite   -> 3
-    TopLayer        -> 4
-    FixedCoordLayer -> 5
-
 numLayers :: Int
-numLayers = 6
+numLayers = length [minBound::Layer .. maxBound]
 --TODO use synonyms for layer numbers
 newtype ShadNum = ShadNum { _unShadNum :: Int }
 polyNum, polyzNum, bezNum, textNum, arcNum, ellNum :: ShadNum

src/Render.hs

@@ -136,13 +136,15 @@ renderFoldable shadV struct = do
 
 ------------------------------end renderFoldable
 renderLayer 
-    :: Int 
+    :: Layer 
     -> MV.MVector (PrimState IO) FullShader
     -> UMV.MVector (PrimState IO) Int
     -> IO ()
 renderLayer layer shads counts = do
-    let layerCounts = UMV.slice (layer * 6) 6 counts
+    let layerCounts = UMV.slice (ln * numLayers) 6 counts
-    MV.imapM_ (drawShaderLay layer layerCounts) shads
+    MV.imapM_ (drawShaderLay ln layerCounts) shads
+  where
+    ln = layerNum layer
 
 bindTO :: TextureObject -> IO ()
 bindTO t = textureBinding Texture2D $= Just t