Work out screen coordinates for connecting infobox

2022-04-10 11:32:05 +01:00
parent 77c3f83d20
commit 0cc12f31ad
9 changed files with 41 additions and 43 deletions
@@ -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 
-    $ color white $ renderListAt 0 0 cfig $ zip ["TEST","ME"] $ repeat white
-    -- $ renderInfoListAt 0 0 cfig w
-    -- $ crDisplayInfo cfig w cr
+creatureDisplayText cfig w cr 
+    = setLayer FixedCoordLayer $ renderInfoListAt 0 0 cfig w
+    $ crDisplayInfo cfig w cr

 creatureDisplayText' :: Configuration -> World -> Creature -> Picture
 creatureDisplayText' cfig w cr 
  | not (_debug_cr_status cfig) = []
  | otherwise
-    = setLayer TopLayer 
-    . setDepth 50 
+    = setLayer DebugLayer 
+    . setDepth 20 
    . translate x y 
    . color white 
    . rotate (0.5 * pi)
@@ -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
@@ -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)]
@@ -14,8 +14,8 @@ fixedSizePicAt
    -> World
    -> Picture
 fixedSizePicAt pic p w 
-    = setLayer TopLayer 
-    . setDepth 50 
+    = setLayer DebugLayer 
+    . 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 
--    . setDepth 50 
+    = setLayer DebugLayer 
+    . 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 TopLayer . color white . setDepth 20 $ arrowPic
+    [ setLayer DebugLayer . translate x y . scale theScale theScale $ pic 
+    , setLayer DebugLayer . color white . setDepth 20 $ arrowPic
    ]
  where
    winps = screenPolygon cfig w
@@ -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
@@ -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
@@ -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
@@ -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
-    BottomLayer     -> 0
-    MidLayer        -> 1
-    BloomLayer      -> 2
-    BloomNoZWrite   -> 3
-    TopLayer        -> 4
-    FixedCoordLayer -> 5
-
+layerNum = fromEnum
 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
@@ -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
-    MV.imapM_ (drawShaderLay layer layerCounts) shads
+    let layerCounts = UMV.slice (ln * numLayers) 6 counts
+    MV.imapM_ (drawShaderLay ln layerCounts) shads
+  where
+    ln = layerNum layer

 bindTO :: TextureObject -> IO ()
 bindTO t = textureBinding Texture2D $= Just t