Move towards resolving picture rendering bug

The bug concerns a mutable vector storing the amount of data that has
been poked.

src/Dodge/Combine/Graph.hs

@@ -1,6 +1,6 @@
 {-# LANGUAGE LambdaCase #-}
 
-module Dodge.Combine.Graph ( combinationsDotGraph) where
+module Dodge.Combine.Graph (combinationsDotGraph) where
 
 import Dodge.Data.CombAmount
 import Data.Bifunctor
@@ -91,7 +91,6 @@ belowNumX bt = case maxShowX bt of
 --toCombNodeLabel (CombNode Right{}) = ""
 
 combinationsDotGraph :: Text
---combinationsDotGraph = toStrict . printDotGraph . graphToDot nonClusteredParams $ combinationsGraph
 combinationsDotGraph =
     toStrict . printDotGraph . graphToDot myParams $
         combinationsGraph

src/Dodge/Data/Config.hs

@@ -98,7 +98,7 @@ data DebugBool
     | Circ_collision_test
     | Show_far_wall_detect
     | Show_walls_near_point_cursor
-    | Show_walls_near_point_you
+    | Show_walls_near_you
     | Show_walls_near_segment
     | Show_zone_near_point_cursor
     | Show_zone_circ
@@ -106,6 +106,7 @@ data DebugBool
     | Show_path_between
     | Show_writable_values
     | Show_mouse_click_pos
+    | Muzzle_positions
     deriving (Eq, Ord, Bounded, Enum, Show)
 
 data ResFactor = DoubleRes | FullRes | HalfRes | QuarterRes | EighthRes | SixteenthRes

src/Dodge/Debug.hs

@@ -2,6 +2,13 @@
 
 module Dodge.Debug (debugEvents, drawDebug) where
 
+import Geometry.Data
+import Dodge.Render.Label
+import Dodge.Data.DoubleTree
+import Dodge.HeldUse
+import Dodge.DoubleTree
+import Dodge.Item.Grammar
+import NewInt
 import AesonHelp
 import Control.Lens
 import Control.Monad
@@ -55,7 +62,7 @@ debugItem = \case
     Show_wall_search_rays -> mempty
     Show_dda_test -> mempty
     Show_far_wall_detect -> mempty
-    Show_walls_near_point_you -> mempty
+    Show_walls_near_you -> mempty
     Show_zone_near_point_cursor -> mempty
     Show_zone_circ -> mempty
     Inspect_wall -> mempty
@@ -70,6 +77,7 @@ debugItem = \case
     Show_mouse_click_pos -> debugMouseClickPos
     Debug_get -> doDebugGet
     Debug_put -> debugPutItems
+    Muzzle_positions -> mempty
 
 debugGet :: Universe -> [String]
 debugGet u = foldMap getPretty $ u ^. uvWorld . cWorld . lWorld . shockwaves
@@ -224,7 +232,7 @@ drawDebug u = \case
     Show_wall_search_rays -> drawWallSearchRays $ _uvWorld u
     Show_dda_test -> drawDDATest $ _uvWorld u
     Show_far_wall_detect -> drawFarWallDetect $ _uvWorld u
-    Show_walls_near_point_you -> drawWallsNearYou $ _uvWorld u
+    Show_walls_near_you -> drawWallsNearYou $ _uvWorld u
     Show_zone_near_point_cursor -> drawZoneNearPointCursor $ _uvWorld u
     Show_zone_circ -> drawZoneCirc $ _uvWorld u
     Inspect_wall -> drawInspectWalls $ _uvWorld u
@@ -239,3 +247,18 @@ drawDebug u = \case
     Show_path_between -> drawPathBetween u
     Show_writable_values -> mempty
     Show_mouse_click_pos -> mempty
+    Muzzle_positions -> showMuzzlePositions u
+
+
+showMuzzlePositions :: Universe -> Picture
+showMuzzlePositions  u = fold $ do
+    cr <- u ^? uvWorld . cWorld . lWorld . creatures . ix 0
+    invid <- cr ^? crManipulation . manObject . imRootSelectedItem . unNInt
+    loc <- invIndents ((\k -> u ^?! uvWorld . cWorld . lWorld . items . ix k) <$> _crInv cr) 
+        ^? ix invid . _2
+    return . color red $ setLayer DebugLayer $ reduceLocDT (f cr) loc
+  where
+    f cr loc = foldMap g $ map (muzzlePos loc cr)  (itemMuzzles $ loc ^. locDT . dtValue . _1)
+      where
+        g :: Point3Q -> Picture
+        g pq = translate3 (pq ^. _1) $ crossPic 5

src/Dodge/Debug/Picture.hs

@@ -72,7 +72,7 @@ lineOnScreenCone cfig w p1 p2 =
 
 drawWallFace :: Config -> World -> Wall -> Picture
 drawWallFace cfig w wall
-    | isRHS sightFrom x y || not (wlIsOpaque wall) = blank
+    | isRHS sightFrom x y || not (wlIsOpaque wall) = mempty
     | otherwise = setDepth (-1) . color (withAlpha 0 black) . polygon $ points
   where
     (x, y) = _wlLine wall
@@ -226,6 +226,7 @@ drawWallsNearYou w = concat $ do
     return $ setLayer DebugLayer $ foldMap f $ wlsNearPoint p w
   where
     f wl = color violet $ thickLine 3 [a, b]
+        <> uncurryV translate (0.5 *^ (a + b)) (scale 0.05 0.05 . text $ show (_wlID wl))
       where
         (a, b) = _wlLine wl
 

src/Dodge/Picture.hs

@@ -8,7 +8,7 @@ import Picture
 
 wedgeOfThickness :: Float -> Point2 -> Point2 -> Picture
 wedgeOfThickness t x y 
-    | x == y    = blank
+    | x == y    = mempty
     | otherwise = fold 
         [uncurryV translate x $ circleSolid (0.5*t)
         ,polygon [x +.+ n x y, x -.- n x y, y]

src/Dodge/Picture/SizeInvariant.hs

@@ -75,7 +75,7 @@ fixedSizePicClampArrow xbord ybord pic p cfig w =
     borderPoint = intersectSegPolyFirst campos p bords
     windowPoint = intersectSegPolyFirst campos p winps
     arrowPic = case borderPoint of
-        Nothing -> blank
+        Nothing -> mempty
         Just bp -> thickLine 5 [bp, fromMaybe p windowPoint]
     (V2 x y) = fromMaybe p borderPoint
     campos = w ^. wCam . camCenter

src/Dodge/Render.hs

@@ -77,6 +77,8 @@ doDrawing' win pdata u = do
                 (0, 0, 0)
                 ws
             )
+    UMV.forM_ pokeCounts $ print
+    print "--"
     nCloudVs' <- -- foldM (pokeCloud $ pdata ^. cloudVBO . vboPtr) 0 (w ^. cWorld . lWorld . clouds)
         V.foldM'
             (pokeCloud (pdata ^. cloudVBO . vboPtr))
@@ -412,7 +414,9 @@ doDrawing' win pdata u = do
     glEnable GL_BLEND
     --glBlendFunc GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA
     glBlendFunc GL_ONE GL_ONE_MINUS_SRC_ALPHA -- assume premultiplied alpha
+    glDisable GL_CULL_FACE
     renderLayer DebugLayer shadV pokeCounts
+    glEnable GL_CULL_FACE
     withArray (scaleMatrix (2 / windowXFloat cfig) (2 / windowYFloat cfig)) $
         glNamedBufferSubData (pdata ^. matUBO) 0 64
     glDepthMask GL_TRUE

src/Dodge/Render/Label.hs

@@ -20,6 +20,7 @@ drawPointLabel p =
 
 drawCrossCol :: Color -> Point2 -> Picture
 drawCrossCol col p = setLayer DebugLayer . color col . uncurryV translate p $ crossPic 5
+--drawCrossCol col p = mempty
 
 drawCross :: Point2 -> Picture
 drawCross = drawCrossCol red

src/Dodge/Render/Picture.hs

@@ -149,7 +149,7 @@ drawQuitTerminal x =
         <> polygonWire (square x)
 
 drawEmptySet :: Float -> Picture
-drawEmptySet x = line [V2 x x, V2 (- x) (- x)] <> circle x
+drawEmptySet x = line [V2 x x, -(V2 x x)] <> circle x
 
 drawReturn :: Float -> Picture
 drawReturn x =

src/Dodge/Render/ShapePicture.hs

@@ -1,12 +1,6 @@
 --{-# LANGUAGE LambdaCase #-}
 module Dodge.Render.ShapePicture (worldSPic) where
 
-import Dodge.DoubleTree
-import Dodge.Data.DoubleTree
-import Dodge.HeldUse
-import NewInt
-import Dodge.Item.Grammar
-import Dodge.Render.Label
 import Dodge.Debug
 import Control.Lens
 import Data.Foldable
@@ -27,30 +21,31 @@ import ShapePicture
 
 worldSPic :: Config -> Universe -> SPic
 worldSPic cfig u =
-    (mempty :!: extraPics cfig u)
+--    (mempty :!: extraPics cfig u)
-        <> foldup propSPic (filtOn _prPos _props)
+--        <> foldup propSPic (filtOn _prPos _props)
-        <> foldMap' debrisSPic (filtOn' (xyV3 . _dbPos) _debris)
+--        <> foldMap' debrisSPic (filtOn' (xyV3 . _dbPos) _debris)
-        <> foldup drawProjectile (filtOn (^. pjPos . _xy) _projectiles)
+--        <> foldup drawProjectile (filtOn (^. pjPos . _xy) _projectiles)
-        <> foldup drawPulseBall (filtOn _pbPos _pulseBalls)
+--        <> foldup drawPulseBall (filtOn _pbPos _pulseBalls)
-        <> foldup (shiftDraw _blPos _blDir (const drawBlock)) (filtOn _blPos _blocks)
+--        <> foldup (shiftDraw _blPos _blDir (const drawBlock)) (filtOn _blPos _blocks)
-        <> foldMap' (shiftDraw _fsPos _fsDir (const _fsSPic)) (filtOn' _fsPos _foreShapes)
+--        <> foldMap' (shiftDraw _fsPos _fsDir (const _fsSPic)) (filtOn' _fsPos _foreShapes)
-        <> foldup (drawCreature (lw ^. items)) (filtOn (^. crPos . _xy) _creatures)
+--        <> foldup (drawCreature (lw ^. items)) (filtOn (^. crPos . _xy) _creatures)
-        <> foldup
+--        <> foldup
-            (Prelude.uncurry floorItemSPic)
+--            (Prelude.uncurry floorItemSPic)
-            ( IM.intersectionWith
+--            ( IM.intersectionWith
-                (,)
+--                (,)
-                (lw ^. items)
+--                (lw ^. items)
-                (filtOn _flItPos _floorItems)
+--                (filtOn _flItPos _floorItems)
-            )
+--            )
-        <> foldup btSPic (filtOn _btPos _buttons)
+--        <> foldup btSPic (filtOn _btPos _buttons)
-        <> foldup (mcSPic (w ^. cWorld)) (filtOn _mcPos _machines)
+--        <> foldup (mcSPic (w ^. cWorld)) (filtOn _mcPos _machines)
-        <> foldMap' drawChasm (w ^. cWorld . chasms)
+--        <> foldMap' drawChasm (w ^. cWorld . chasms)
-        <> w ^. cWorld . lWorld . tempSPic
+--        <> w ^. cWorld . lWorld . tempSPic
-        <> testSPic cfig u
+--        <> 
+          testSPic cfig u
   where
     w = u ^. uvWorld
     lw = w ^. cWorld . lWorld
-    foldup = foldMap'
+    --foldup = foldMap'
     filtOn f g = IM.filter (pointIsClose . f) (g lw)
     filtOn' f g = filter (pointIsClose . f) (g lw)
     pointIsClose = cullPoint cfig w
@@ -59,18 +54,24 @@ testSPic :: Config -> Universe -> SPic
 testSPic cfig u = noShape $ testPic cfig u
 
 testPic :: Config -> Universe -> Picture
-testPic _ u = fold $ do
+testPic _ _ = setLayer DebugLayer 
-    cr <- u ^? uvWorld . cWorld . lWorld . creatures . ix 0
+    $ mempty
---    return mempty
+--    <> color white (line [0,10])
-    invid <- cr ^? crManipulation . manObject . imRootSelectedItem . unNInt
+--    <> text "A"
-    loc <- invIndents ((\k -> u ^?! uvWorld . cWorld . lWorld . items . ix k) <$> _crInv cr) 
+    <> translate 20 20 (arc pi 0 10)
-        ^? ix invid . _2
+    <> translate 0 20 (circleSolidCol white red 10)
-    return . color red $ setLayer DebugLayer $ reduceLocDT (f cr) loc
+--    fold $ do
-  where
+--    cr <- u ^? uvWorld . cWorld . lWorld . creatures . ix 0
-    f cr loc = foldMap g $ map (muzzlePos loc cr)  (itemMuzzles $ loc ^. locDT . dtValue . _1)
+----    return mempty
-      where
+--    invid <- cr ^? crManipulation . manObject . imRootSelectedItem . unNInt
-        g :: Point3Q -> Picture
+--    loc <- invIndents ((\k -> u ^?! uvWorld . cWorld . lWorld . items . ix k) <$> _crInv cr) 
-        g pq = translate3 (pq ^. _1) $ crossPic 5
+--        ^? ix invid . _2
+--    return . color red $ setLayer DebugLayer $ reduceLocDT (f cr) loc
+--  where
+--    f cr loc = foldMap g $ map (muzzlePos loc cr)  (itemMuzzles $ loc ^. locDT . dtValue . _1)
+--      where
+--        g :: Point3Q -> Picture
+--        g pq = translate3 (pq ^. _1) $ crossPic 5
 
 
 drawBlock :: Block -> SPic

src/Dodge/Update.hs

@@ -328,7 +328,7 @@ muzzleWallCheck w cr = fromMaybe cr $ do
     let ps = reduceLocDT f loc ^.. each . _1 . _xy
         cp = cr ^. crPos . _xy
     r <- boundPointsRect (cp : ps)
-    let wls = uncurry wlsNearRect r w
+    let wls = uncurry wlsNearRect r w & filter (not . _wlTouchThrough)
         vs = mapMaybe (g cp wls) ps
     return $ if null vs 
         then cr

src/Picture/Base.hs

@@ -5,7 +5,6 @@ module Picture.Base (
     module Picture.Data,
     module Picture.Arc,
     module Color,
-    blank,
     polygon,
     polygonWire,
     polygonCol,
@@ -17,7 +16,6 @@ module Picture.Base (
     --thickArcFull,
     thickCircle,
     thickLine,
-    lineThick,
     thickLineCol,
     circleSolid,
     circleSolidCol,
@@ -49,7 +47,6 @@ module Picture.Base (
     mirroryz,
     mirrorxz,
     overPos,
-    picMap,
     fold,
 ) where
 
@@ -59,18 +56,10 @@ import Geometry
 import Picture.Arc
 import Picture.Data
 
-blank :: Picture
-{-# INLINE blank #-}
-blank = mempty
-
 polygonWire :: [Point2] -> Picture
 {-# INLINE polygonWire #-}
 polygonWire ps = line (ps <> [head ps])
 
-picMap :: (Verx -> Verx) -> Picture -> Picture
-{-# INLINE picMap #-}
-picMap = map
-
 -- | Expects clockwise input.
 polygon :: [Point2] -> Picture
 {-# INLINE polygon #-}
@@ -110,7 +99,7 @@ poly3Col = map f . polyToTris
 
 color :: RGBA -> Picture -> Picture
 {-# INLINE color #-}
-color = picMap . overCol . const
+color = fmap . overCol . const
 
 translateH :: Float -> Float -> Point3 -> Point3
 {-# INLINE translateH #-}
@@ -118,30 +107,30 @@ translateH !a !b (V3 x y z) = V3 (x + a) (y + b) z
 
 translate :: Float -> Float -> Picture -> Picture
 {-# INLINE translate #-}
-translate x = picMap . overPos . translateH x
+translate x = fmap . overPos . translateH x
 
 translate3 :: Point3 -> Picture -> Picture
 {-# INLINE translate3 #-}
-translate3 = picMap . overPos . (+.+.+)
+translate3 = fmap . overPos . (+.+.+)
 
 tranRot :: V2 Float -> Float -> Picture -> Picture
 {-# INLINE tranRot #-}
-tranRot (V2 x y) r = picMap $ overPos (translateH x y . rotate3 r)
+tranRot (V2 x y) r = fmap $ overPos (translateH x y . rotate3 r)
 
 setDepth :: Float -> Picture -> Picture
 {-# INLINE setDepth #-}
 --setDepth d = map $ second $ overPos (\(x,y,_) -> (x,y,d))
-setDepth d = picMap $ overPos (\(V3 x y _) -> V3 x y d)
+setDepth d = fmap $ overPos (\(V3 x y _) -> V3 x y d)
 
 addDepth :: Float -> Picture -> Picture
 {-# INLINE addDepth #-}
 --addDepth d = map $ second $ overPos (\(x,y,z) -> (x,y,z+d))
-addDepth d = picMap $ overPos (\(V3 x y z) -> V3 x y (z + d))
+addDepth d = fmap $ overPos (\(V3 x y z) -> V3 x y (z + d))
 
 -- TODO change the Int here to a dedicated type
 setLayer :: Layer -> Picture -> Picture
 {-# INLINE setLayer #-}
-setLayer i = picMap f
+setLayer i = fmap f
   where
     f v = v{_vxLayer = i}
 
@@ -151,11 +140,11 @@ scale3 a b (V3 x y z) = V3 (x * a) (y * b) z
 
 scale :: Float -> Float -> Picture -> Picture
 {-# INLINE scale #-}
-scale x = picMap . overPos . scale3 x
+scale x = fmap . overPos . scale3 x
 
 rotate :: Float -> Picture -> Picture
 {-# INLINE rotate #-}
-rotate = picMap . overPos . rotate3
+rotate = fmap . overPos . rotate3
 
 makeArc :: Float -> Point2 -> [Point2]
 {-# INLINE makeArc #-}
@@ -246,16 +235,6 @@ lineCol :: [(Point2, RGBA)] -> Picture
 {-# INLINE lineCol #-}
 lineCol = thickLineCol 1
 
-lineThick :: Float -> [Point2] -> Picture
-{-# INLINE lineThick #-}
-lineThick t = fold . f
-  where
-    f (x : y : ys)
-        | x == y = f (x : ys)
-        | otherwise = polygon [x +.+ n x y, x -.- n x y, y -.- n x y, y +.+ n x y] : f (y : ys)
-    f _ = []
-    n a b = (t * 0.5) *.* errorNormalizeV 42 (vNormal (a -.- b))
-
 thickLine :: Float -> [Point2] -> Picture
 {-# INLINE thickLine #-}
 thickLine t = fold . f
@@ -266,6 +245,7 @@ thickLine t = fold . f
       where
         n = (t * 0.5) *.* errorNormalizeV 42 (vNormal (x -.- y))
     f _ = []
+    --f _ = error "Tried to draw line without at least two points"
 
 thickLineCol :: Float -> [(Point2, RGBA)] -> Picture
 {-# INLINE thickLineCol #-}
@@ -348,11 +328,11 @@ charToTuple xoff c
 --    offset = fromIntegral (fromEnum c) - 32
 
 mirrorxz :: Picture -> Picture
-mirrorxz = picMap (overPos flipy)
+mirrorxz = fmap (overPos flipy)
   where
     flipy (V3 x y z) = V3 x (negate y) z
 
 mirroryz :: Picture -> Picture
-mirroryz = picMap (overPos flipx)
+mirroryz = fmap (overPos flipx)
   where
     flipx (V3 x y z) = V3 (negate x) y z

src/Picture/Data.hs

@@ -19,8 +19,8 @@ data Verx = Verx
 
 data Layer
     = BloomLayer
---    | BloomNoZWrite
     | DebugLayer
+    | DebugLayer1
     | FixedCoordLayer
     deriving (Eq, Ord, Enum, Bounded, Show, Read) --Generic, Flat)
 

src/Polyhedra.hs

@@ -20,9 +20,6 @@ import Data.List
 import Data.Bifunctor
 import Control.Lens
 
-picFormat :: [Verx] -> Picture
-picFormat = id
-
 translateXY :: Float -> Float -> Polyhedra -> Polyhedra
 translateXY x y = pyFaces %~ map (map $ first tran)
   where
@@ -120,12 +117,7 @@ boxABC a b c =
     faceNA = rhombus c b
 
 polyToPics :: Polyhedra -> [Picture]
-polyToPics = map helpPoly3D . _pyFaces
+polyToPics = map poly3Col . _pyFaces
-
-helpPoly3D :: [(Point3, Point4)] -> Picture
-helpPoly3D = picFormat . map f . polyToTris
-  where
-    f (pos,col) = Verx pos col [] minBound PolyShad
 
 polysToPic :: [Polyhedra] -> Picture
 polysToPic = foldMap (fold . polyToPics)

src/Render.hs

@@ -227,7 +227,7 @@ renderLayer ::
     UMV.MVector (PrimState IO) Int ->
     IO ()
 renderLayer layer shads counts = do
-    let layerCounts = UMV.slice (ln * numLayers) numShads counts
+    let layerCounts = UMV.slice (ln * numShads) numShads counts
     MV.imapM_ (drawShaderLay ln layerCounts) shads
   where
     ln = fromEnum layer

src/Shader.hs

@@ -1,5 +1,6 @@
 module Shader (drawShaderLay) where
 
+--import Picture.Data
 import Control.Monad.Primitive
 import qualified Data.Vector.Unboxed.Mutable as UMV
 import Graphics.GL.Core45
@@ -12,6 +13,7 @@ drawShaderLay l countsVector shadIn fs = do
     i <- UMV.read countsVector shadIn
     glUseProgram (fst fs)
     glUniform1i 0 . fromIntegral $ (l * numSubElements)
+--    if l == fromEnum DebugLayer && shadIn == 0 then print i else return ()
     glDrawArrays
         GL_TRIANGLES
         (fromIntegral $ l * numSubElements)

src/Shader/Poke.hs

@@ -492,7 +492,7 @@ pokeLayVerx vbos counts vx = do
   where
     sn = fromEnum shadnum
     shadnum = _vxShadNum vx
-    vecPos = theLayer * numLayers + sn
+    vecPos = theLayer * numShads + sn
     theLayer = fromEnum $ _vxLayer vx
     thePos = _vxPos vx
     theCol = _vxCol vx

src/ShapePicture.hs

@@ -40,7 +40,7 @@ noShape = (mempty :!:)
 
 overPosSP :: (Point3 -> Point3) -> SPic -> SPic
 {-# INLINE overPosSP #-}
-overPosSP f = bimap (overPosSH f) (picMap $ overPos f)
+overPosSP f = bimap (overPosSH f) (fmap $ overPos f)
 
 translateSPxy :: Float -> Float -> SPic -> SPic
 {-# INLINE translateSPxy #-}