Partial fix of inventory rendering

2021-07-23 12:48:40 +02:00
parent b4d89b16fa
commit e453065afe
7 changed files with 79 additions and 14 deletions
@@ -79,6 +79,7 @@ doDrawing pdata w = do
        then renderTextureWalls pdata nWalls
        else renderBlankWalls pdata nWalls
    --_ <- renderFoldable pdata $ (picToAlt (Just 0) (polysToPic $ foregroundPics w) :: [RenderType])
+    --_ <- renderFoldable pdata $ (picToAlt (Just 0) pic :: [RenderType])
    _ <- renderFoldable pdata $ picToLTree (Just 0) (polysToPic $ foregroundPics w)
    _ <- renderFoldable pdata $ picToLTree (Just 0) pic
    _ <- renderShader (_textureArrayShader pdata) (_floorTiles w)
@@ -162,11 +163,12 @@ doDrawing pdata w = do
            activeTexture $= TextureUnit 0
    -- draw overlay
    bufferUBO $ isoMatrix 0 1 (0,0) (2,2)
-    --depthFunc $= Just Always
-    depthMask $= Enabled
+    depthFunc $= Just Always
+    depthMask $= Disabled
    blend $= Enabled
    blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
    _ <- renderFoldable pdata (picToLTree Nothing $ fixedCoordPictures w)
+    depthMask $= Enabled

    eTicks <- SDL.ticks
    return (eTicks - sTicks)
@@ -17,7 +17,7 @@ winScale :: World -> Picture -> Picture
 winScale w = scale (2 / getWindowX w) (2 / getWindowY w)

 hudDrawings :: World -> Picture
-hudDrawings w = setLayer 1 . setDepth (-0.5) . pictures $
+hudDrawings w = pictures $
    [ winScale w . dShadCol white $ displayHP 0 w
    , winScale w . translate (-390) 20 . scale 0.05 0.05 . dShadCol white $ text (_testString w)
    ] 
@@ -221,8 +221,8 @@ closeObjectTexts w = pictures $ zipWith renderList [(0::Int)..] (map colAndText
 {- | Colour picture and add black drop shadow. -}
 dShadCol :: Color -> Picture -> Picture
 dShadCol c p = pictures
-    [ color black $ uncurry translate (1.2,-1.2) p
-    , color c p
+    [ color c p
+    , color black $ uncurry translate (1.2,-1.2) p
    ]

 drawListCursor :: Color -> Int -> World -> Picture
@@ -46,9 +46,9 @@ fixedCoordPictures w = case _menuLayers w of

 customMouseCursor :: World -> Picture
 customMouseCursor w = 
-    setDepth (-1)
-    . scale (2 /getWindowX w) (2/ getWindowY w) 
+    scale (2 /getWindowX w) (2/ getWindowY w) 
    . uncurry translate (_mousePos w)
+    . color white
    $ pictures [ line [(-5,0),(5,0)] , line [(0,-5),(0,5)] ]

 testPic :: World -> [Picture]
@@ -46,6 +46,7 @@ module Picture
    , mixColors
    , zeroZ
    , setDepth
+    , addDepth
    , setLayer
    )
  where
@@ -148,6 +149,10 @@ setDepth :: Float -> Picture -> Picture
 {-# INLINE setDepth #-}
 setDepth d = OverPic (\(x,y,_) -> (x,y,d)) id

+addDepth :: Float -> Picture -> Picture
+{-# INLINE addDepth #-}
+addDepth d = OverPic (\(x,y,z) -> (x,y,z+d)) id
+
 setLayer :: Int -> Picture -> Picture
 {-# INLINE setLayer #-}
 setLayer = OnLayer
@@ -37,22 +37,27 @@ data FTree a
    = FBranch (a -> a) (FTree a)
    | FBranches [FTree a]
    | FLeaf a
-
 instance Foldable FTree where
    foldMap g (FBranch f t) = foldMap (g . f) t
    foldMap g (FBranches ts) = mconcat $ map (foldMap g) ts
    foldMap g (FLeaf x) = g x
    {-# INLINE foldMap #-}
-
+instance Functor FTree where
+    fmap g (FBranch f t) = fmap (g . f) t
+    fmap f (FBranches ts) = FBranches $ fmap (fmap f) ts
+    fmap f (FLeaf x) = FLeaf (f x)
+    {-# INLINE fmap #-}
+    
 {- Tree with values at and only at the leaves. -}
 data LTree a
    = LBranches [LTree a]
-    | LLeaf !a
+    | LLeaf a
 instance Foldable LTree where
    foldMap g (LBranches ts) = mconcat $ map (foldMap g) ts
    foldMap g (LLeaf a) = g a
    {-# INLINE foldMap #-}
    foldr _ x (LBranches []) = x
+    --foldr g x (LBranches (t:ts)) = foldr g x t `seq` foldr g (foldr g x t) (LBranches ts)
    foldr g x (LBranches (t:ts)) = foldr g (foldr g x t) (LBranches ts)
    --foldr g x (LBranches (t:ts)) = foldr g (foldr g x (LBranches ts)) t
    foldr g x (LLeaf y) = g y x
@@ -1,8 +1,10 @@
 {- Transform a picture into renderable objects. -}
 module Picture.Tree
    ( picToLTree
+    , picToFTree
    , picToRenderList
    , picToAlt
+    , picToRList
    )
    where
 import Picture.Data
@@ -11,6 +13,7 @@ import Geometry.Data

 import Data.Bifunctor
 import Data.List
+import qualified Data.DList as DL
 import Control.Applicative
 --import Data.Maybe (isNothing)

@@ -58,10 +61,54 @@ picToLTree j (Pictures pics) = LBranches $ map (picToLTree j) pics
 picToLTree j (OverPic f f' (OverPic g g' pic)) = picToLTree j $ OverPic (f . g) (f' . g') pic
 picToLTree j (OverPic f f' (Pictures ps)) = LBranches (map (picToLTree j . OverPic f f') ps)
 picToLTree j (OverPic f f' pic) = overPos f . overCol f' <$> picToLTree j pic
-picToLTree (Just j) (OnLayer i pic) | j == i = picToLTree Nothing pic
-                                    | otherwise = LBranches []
+picToLTree (Just j) (OnLayer i pic) 
+    | j == i = picToLTree Nothing pic
+    | otherwise = LBranches []
 picToLTree Nothing  (OnLayer _ pic) = picToLTree Nothing pic

+picToFTree 
+    :: Maybe Int -- ^ Layer filter. Draw 'Nothing' when value is the same as at the leaf.
+    -> Picture
+    -> FTree RenderType
+--{-# INLINE picToFTree #-}
+picToFTree _ (Polygon ps)
+    = FLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
+picToFTree _ (PolygonZ ps z)
+    = FLeaf $ RenderPolyZ $ zip3 (map zeroZ $ polyToTris ps) (repeat black) (repeat z)
+picToFTree _ (PolygonCol vs)
+    = FLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs
+  where 
+    (ps,cs) = unzip vs
+picToFTree _ (Poly3D vs) = FLeaf $ RenderPoly $ polyToTris vs
+picToFTree _ (BezierQuad vs) = FLeaf $ RenderBezQ $ zip3 (map zeroZ ps) cols rs
+  where 
+    (ps,cols,offps,rads) = unzip4 vs
+    rs = zipWith (\(x,y) (z,w) -> (x,y,z,w)) offps rads
+picToFTree _ (Circle colC colE r) = FLeaf $ RenderEllipse 
+    [( (-r, r,0), colC)
+    ,( (-r,-r,0), colE)
+    ,( ( r,-r,0), black)
+    ]
+picToFTree _ (ThickArc startA endA rad wdth) = FLeaf $ RenderArc 
+    [(  (0,0,0),black,(0,0,wdth))
+    ,((xa,ya,0),black,(1,0,wdth))
+    ,((xb,yb,0),black,(1,1,wdth))
+    ,(  (0,0,0),black,(0,0,wdth))
+    ,((xb,yb,0),black,(1,1,wdth))
+    ,((xc,yc,0),black,(0,1,wdth))
+    ]
+  where
+    (xa,ya) = rotateV startA (rad,0)
+    (xb,yb) = rotateV (0.5 * (startA + endA)) (rad * sqrt 2,0)
+    (xc,yc) = rotateV endA (rad,0)
+picToFTree _ (Text s) = FLeaf $ RenderText $ stringToList s
+picToFTree _ Blank = FBranches []
+picToFTree j (Pictures pics) = FBranches $ map (picToFTree j) pics
+picToFTree j (OverPic f f' pic) = FBranch (overPos f . overCol f') $ picToFTree j pic
+picToFTree (Just j) (OnLayer i pic) | j == i = picToFTree Nothing pic
+                                    | otherwise = FBranches []
+picToFTree Nothing  (OnLayer _ pic) = picToFTree Nothing pic
+
 -- might want to use the Alt newType
 picToAlt
    :: (Alternative t, Monoid (t RenderType))
@@ -80,6 +127,12 @@ picToAlt (Just j) (OnLayer i pic)
 picToAlt Nothing (OnLayer _ pic) = picToAlt Nothing pic
 picToAlt _ pic = pure $ picToRenderType pic

+picToRList 
+    :: Maybe Int -- ^ Layer filter. Draw 'Nothing' when value is the same as at the leaf.
+    -> Picture
+    -> DL.DList RenderType
+picToRList = picToAlt
+
 picToRenderList
    :: Maybe Int -- ^ Layer filter. Draw 'Nothing' when value is the same as at the leaf.
    -> Picture
@@ -209,7 +209,7 @@ cleanUpRenderPreload pd = do
    freeShaderPointers $ _lightingOccludeShader pd
    freeShaderPointers $ _fullscreenShader pd

-{-# INLINE pokeBezQStrat #-}
+--{-# INLINE pokeBezQStrat #-}
 pokeBezQStrat :: RenderType -> [[Float]]
 pokeBezQStrat (RenderBezQ vs) = fmap 
    (\((x,y,z),(r,g,b,a),(s,t,u,v)) -> [x,y,z,r,g,b,a,s,t,u,v]) 
@@ -221,7 +221,7 @@ pokeTriTweakZ :: RenderType -> [[Float]]
 pokeTriTweakZ (RenderPolyZ vs) = fmap (\(p,co,z) -> flat3 p ++ [z] ++ flat4 co) vs
 pokeTriTweakZ _ = []

-{-# INLINE pokeTriStrat #-}
+--{-# INLINE pokeTriStrat #-}
 pokeTriStrat,pokeCharStrat,pokeArcStrat,pokeEllStrat :: RenderType -> [[Float]]
 pokeTriStrat (RenderPoly vs) = fmap (\(p,co) -> flat3 p ++ flat4 co) vs
 pokeTriStrat _ = []