justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Add layered drawing of pictures

Browse Source
This commit is contained in:
jgk
2021-02-24 03:35:42 +01:00
parent a853c2d946
commit 2afe40594e
4 changed files with 150 additions and 92 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Rendering.hs
+5 -4
View File
@@ -151,8 +151,10 @@ hudDrawings w = (onLayer InvLayer)
$ pictures
[ displayInv 0 w
, dShadCol white $ displayHP 0 w
, dShadCol (itCol (yourItem w))
$ drawCursor w, translate (-390) 20
, --color (itCol (yourItem w))
color white
$ drawCursor w
, translate (-390) 20
$ scale 0.05 0.05 $ dShadCol white $ text (_testString w)
]
where itCol = fromMaybe (greyN 0.5) . (^? itInvColor)
@@ -171,8 +173,7 @@ drawCursor :: World -> Picture
drawCursor w = translate (105-halfWidth w)
(halfHeight w - (25* (fromIntegral iPos)) - 20
)
-- $ rectangleWire 200 25
$ color white
$ setLayer 2
$ line [(200,12.5),(-100,12.5),(-100,-12.5),(200,-12.5)]
where iPos = _crInvSel $ _creatures w IM.! _yourID w
src/Picture.hs
+23 -7
View File
@@ -40,6 +40,7 @@ module Picture
, mixColors
, zeroZ
, setDepth
, setLayer
)
where
import Geometry
@@ -69,11 +70,11 @@ black = (0,0,0,1)
polygon :: [Point2] -> Picture
{-# INLINE polygon #-}
polygon = Polygon
polygon = Polygon 0
polygonCol :: [(Point2,RGBA)] -> Picture
{-# INLINE polygonCol #-}
polygonCol = PolygonCol
polygonCol = PolygonCol 0
--polygon :: [Point2] -> Picture
--{-# INLINE polygon #-}
@@ -101,6 +102,21 @@ setDepth :: Float -> Picture -> Picture
{-# INLINE setDepth #-}
setDepth d pic = SetDepth d pic
setLayer :: Int -> Picture -> Picture
setLayer _ Blank = Blank
setLayer i (Polygon _ ps) = Polygon i ps
setLayer i (PolygonCol _ ps) = PolygonCol i ps
setLayer i (Circle _ x) = Circle i x
setLayer i (ThickArc _ a b r w) = ThickArc i a b r w
setLayer i (Line _ x) = Line i x
setLayer i (Scale x y p) = Scale x y $ setLayer i p
setLayer i (Translate x y p) = Translate x y $ setLayer i p
setLayer i (Rotate x p) = Rotate x $ setLayer i p
setLayer i (SetDepth x p) = SetDepth x $ setLayer i p
setLayer i (Color x p) = Color x $ setLayer i p
setLayer i (Pictures p) = Pictures $ map (setLayer i) p
scale3 :: Float -> Float -> Point3 -> Point3
{-# INLINE scale3 #-}
scale3 a b (x,y,z) = (x*a,y*b,z)
@@ -134,19 +150,19 @@ makeArc rad (a,b) = zipWith rotateV as $ repeat (0,rad)
circleSolid :: Float -> Picture
{-# INLINE circleSolid #-}
--circleSolid rad = polygon $ makeArc rad (0,2*pi)
circleSolid = Circle
circleSolid = Circle 0
circle :: Float -> Picture
{-# INLINE circle #-}
circle rad = line $ makeArc rad (0,2*pi)
circle rad = thickArc 0 (2*pi) rad 1
text :: String -> Picture
{-# INLINE text #-}
text = Text
text = Text 2
line :: [Point2] -> Picture
{-# INLINE line #-}
line = Line
line = Line 0
thickLine :: [Point2] -> Float -> Picture
{-# INLINE thickLine #-}
@@ -173,7 +189,7 @@ arc startA endA rad = thickArc startA endA rad 1
thickArc :: Float -> Float -> Float -> Float -> Picture
{-# INLINE thickArc #-}
thickArc = ThickArc
thickArc = ThickArc 0
--thickArc startA endA rad wdth
-- = thickLine (makeArc rad (startA,endA)) wdth
src/Picture/Data.hs
+6 -6
View File
@@ -42,18 +42,18 @@ data RenderType
data Picture
= Blank
| Text String
| Polygon [Point2]
| PolygonCol [(Point2,RGBA)]
| Circle Float
| ThickArc Float Float Float Float
| Text Int String
| Polygon Int [Point2]
| PolygonCol Int [(Point2,RGBA)]
| Circle Int Float
| ThickArc Int Float Float Float Float
| Line Int [Point2]
| Scale Float Float Picture
| Translate Float Float Picture
| Rotate Float Picture
| SetDepth Float Picture
| Color RGBA Picture
| Pictures [Picture]
| Line [Point2]
blank :: Picture
{-# INLINE blank #-}
src/Picture/Render.hs
+116 -75
View File
@@ -26,7 +26,7 @@ import qualified Graphics.Rendering.OpenGL as GL
import Data.Foldable
import Data.List
import qualified Data.Vector.Storable as V
import qualified Data.DList as DL
import qualified Data.IntMap as IM
import Control.DeepSeq
@@ -93,23 +93,54 @@ charToTuple :: Char -> (Point3,Point4,Point2)
charToTuple c = ((0,0,0),white,(offset,100))
where offset = fromIntegral (fromEnum c) - 32
picToFTree :: Picture -> FTree RenderType
--picToFTree :: Picture -> IM.IntMap (FTree RenderType)
--{-# INLINE picToFTree #-}
--picToFTree (Polygon i ps) = IM.singleton i $ FLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
--picToFTree (PolygonCol i vs)
-- = let (ps,cs) = unzip vs
-- in IM.singleton i $ FLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs
--picToFTree (Circle i r) = IM.singleton i $ FLeaf $ RenderCirc $ ((0,0,0),black,r)
--picToFTree (ThickArc i startA endA rad wdth)
-- = IM.singleton i $ FLeaf $ RenderArc $ ((0,0,0),black,(startA,endA,rad,wdth))
--picToFTree Blank = IM.singleton 0 $ FLeaf $ RenderBlank
--picToFTree (Line i ps) = IM.singleton 0 $ FLeaf $ RenderLine $ zip (map zeroZ $ doubleLine ps) $ repeat black
--picToFTree (Text i s) = IM.singleton i $ FLeaf $ RenderText $ stringToList s
--picToFTree (Scale x y pic) = fmap (FBranch (scaleRen x y)) $ picToFTree pic
--picToFTree (Translate x y pic) = fmap (FBranch (translateRen x y)) $ picToFTree pic
--picToFTree (Rotate a pic) = fmap (FBranch (rotateRen a)) $ picToFTree pic
--picToFTree (SetDepth a pic) = fmap (FBranch (setDepthRen a)) $ picToFTree pic
--picToFTree (Color c pic) = fmap (FBranch (colorRen c)) $ picToFTree pic
--picToFTree (Pictures pics) = fmap FBranches $ IM.unionsWith (++) $ map (fmap return . picToFTree) pics
picToFTree :: Int -> Picture -> FTree RenderType
{-# INLINE picToFTree #-}
picToFTree (Polygon ps) = FLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
picToFTree (PolygonCol vs) = let (ps,cs) = unzip vs
in FLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs
picToFTree (Circle r) = FLeaf $ RenderCirc $ ((0,0,0),black,r)
picToFTree (ThickArc startA endA rad wdth)
= FLeaf $ RenderArc $ ((0,0,0),black,(startA,endA,rad,wdth))
picToFTree Blank = FLeaf $ RenderBlank
picToFTree (Text s) = FLeaf $ RenderText $ stringToList s
picToFTree (Scale x y pic) = FBranch (scaleRen x y) $ picToFTree pic
picToFTree (Translate x y pic) = FBranch (translateRen x y) $ picToFTree pic
picToFTree (Rotate a pic) = FBranch (rotateRen a) $ picToFTree pic
picToFTree (SetDepth a pic) = FBranch (setDepthRen a) $ picToFTree pic
picToFTree (Color c pic) = FBranch (colorRen c) $ picToFTree pic
picToFTree (Pictures pics) = FBranches $ map picToFTree pics
picToFTree (Line ps) = FLeaf $ RenderLine $ zip (map zeroZ $ doubleLine ps) $ repeat black
picToFTree x (Polygon i ps)
| i == x = FLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
| otherwise = FLeaf RenderBlank
picToFTree x (PolygonCol i vs)
| i /= x = FLeaf RenderBlank
| otherwise =
let (ps,cs) = unzip vs
in FLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs
picToFTree x (Circle i r)
| i == x = FLeaf $ RenderCirc $ ((0,0,0),black,r)
| otherwise = FLeaf RenderBlank
picToFTree x (ThickArc i startA endA rad wdth)
| i == x = FLeaf $ RenderArc $ ((0,0,0),black,(startA,endA,rad,wdth))
| otherwise = FLeaf RenderBlank
picToFTree x (Line i ps)
| i == x = FLeaf $ RenderLine $ zip (map zeroZ $ doubleLine ps) $ repeat white
| otherwise = FLeaf RenderBlank
picToFTree x (Text i s)
| i == x = FLeaf $ RenderText $ stringToList s
| otherwise = FLeaf RenderBlank
picToFTree j Blank = FLeaf RenderBlank
picToFTree j (Scale x y pic) = FBranch (scaleRen x y) $ picToFTree j pic
picToFTree j (Translate x y pic) = FBranch (translateRen x y) $ picToFTree j pic
picToFTree j (Rotate a pic) = FBranch (rotateRen a) $ picToFTree j pic
picToFTree j (SetDepth a pic) = FBranch (setDepthRen a) $ picToFTree j pic
picToFTree j (Color c pic) = FBranch (colorRen c) $ picToFTree j pic
picToFTree j (Pictures pics) = FBranches $ map (picToFTree j) pics
doubleLine :: [Point2] -> [Point2]
doubleLine (x:y:xs) = concat $ zipWith (:) (init (x:y:xs)) $ map (\a -> [a]) (y:xs)
@@ -281,73 +312,83 @@ renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints p
blendFuncSeparate $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One))
clear [DepthBuffer]
-- poke necessary data
(nTriVs,nTextVs,numCircVs,nLineVs,nArcVs)
-- <- F.foldM (theFold (_ptrPosVBO pdata, _ptrColVBO pdata)
<- F.foldM (theFold (twoPtrsVAO $ _triVAO pdata)
(threePtrsVAO $ _textVAO pdata)
(threePtrsVAO $ _circVAO pdata)
(twoPtrsVAO $ _lineVAO pdata)
(threePtrsVAO $ _arcVAO pdata)
) $ picToFTree pic
-- draw layer 0
renderTree pdata rot zoom (tranx,trany) (winx,winy) (picToFTree 0 pic)
depthFunc $= Just Less
currentProgram $= Just (_backShader pdata)
bindVertexArrayObject $= Just (_vao $ _backVAO pdata)
let backPtr = (\(_,x,_) -> x) $ head $ _vaoBufferTargets $ _backVAO pdata
backPtr2 = (\(_,x,_) -> x) $ (_vaoBufferTargets $ _backVAO pdata) !! 1
pokeFourOff backPtr 0 (tranx,trany,rot,zoom)
pokeTwoOff backPtr2 0 (winx,winy)
bindArrayBuffers 1 $ _vaoBufferTargets $ _backVAO pdata
textureBinding Texture2D $= Just (_textures pdata !! 1)
drawArrays Points (fromIntegral 0) (fromIntegral 1)
-- draw triangles
currentProgram $= Just (_basicShader pdata)
bindVertexArrayObject $= Just (_vao $ _triVAO pdata)
bindArrayBuffers nTriVs $ _vaoBufferTargets $ _triVAO pdata
drawArrays Triangles 0 (fromIntegral $ nTriVs)
-- draw circles
currentProgram $= Just (_circShader pdata)
uniform (_uniWinSize pdata) $= Vector2 winx winy
uniform (_csZoomUni pdata) $= zoom
bindVertexArrayObject $= Just (_vao $ _circVAO pdata)
bindArrayBuffers numCircVs $ _vaoBufferTargets $ _circVAO pdata
drawArrays Points 0 (fromIntegral $ numCircVs)
-- draw arcs
currentProgram $= Just (_arcShader pdata)
uniform (_asWinUni pdata) $= Vector2 winx winy
uniform (_asZoomUni pdata) $= zoom
bindVertexArrayObject $= Just (_vao $ _arcVAO pdata)
bindArrayBuffers nArcVs $ _vaoBufferTargets $ _arcVAO pdata
drawArrays Points 0 (fromIntegral $ nArcVs)
renderTree pdata rot zoom (tranx,trany) (winx,winy) $ picToFTree 1 pic
-- reset blend so that light map doesn't apply
blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
-- draw lines
currentProgram $= Just (_basicShader pdata)
bindVertexArrayObject $= Just (_vao $ _lineVAO pdata)
bindArrayBuffers nTriVs $ _vaoBufferTargets $ _lineVAO pdata
drawArrays Lines 0 (fromIntegral $ nLineVs)
-- draw text
currentProgram $= Just (_textShader pdata)
bindVertexArrayObject $= Just (_vao $ _textVAO pdata)
bindArrayBuffers nTextVs $ _vaoBufferTargets $ _textVAO pdata
textureBinding Texture2D $= Just (_textures pdata !! 0)
drawArrays Points 0 (fromIntegral $ nTextVs)
renderTree pdata rot zoom (tranx,trany) (winx,winy) $ picToFTree 2 pic
--
---- poke necessary data
-- (nTriVs,nTextVs,numCircVs,nLineVs,nArcVs)
---- <- F.foldM (theFold (_ptrPosVBO pdata, _ptrColVBO pdata)
-- <- F.foldM (theFold (twoPtrsVAO $ _triVAO pdata)
-- (threePtrsVAO $ _textVAO pdata)
-- (threePtrsVAO $ _circVAO pdata)
-- (twoPtrsVAO $ _lineVAO pdata)
-- (threePtrsVAO $ _arcVAO pdata)
-- ) $ (picToFTree 0 pic)
--
-- depthFunc $= Just Less
--
-- currentProgram $= Just (_backShader pdata)
-- bindVertexArrayObject $= Just (_vao $ _backVAO pdata)
-- let backPtr = (\(_,x,_) -> x) $ head $ _vaoBufferTargets $ _backVAO pdata
-- backPtr2 = (\(_,x,_) -> x) $ (_vaoBufferTargets $ _backVAO pdata) !! 1
-- pokeFourOff backPtr 0 (tranx,trany,rot,zoom)
-- pokeTwoOff backPtr2 0 (winx,winy)
-- bindArrayBuffers 1 $ _vaoBufferTargets $ _backVAO pdata
-- textureBinding Texture2D $= Just (_textures pdata !! 1)
-- drawArrays Points (fromIntegral 0) (fromIntegral 1)
--
---- draw triangles
-- currentProgram $= Just (_basicShader pdata)
-- bindVertexArrayObject $= Just (_vao $ _triVAO pdata)
-- bindArrayBuffers nTriVs $ _vaoBufferTargets $ _triVAO pdata
-- drawArrays Triangles 0 (fromIntegral $ nTriVs)
---- draw circles
-- currentProgram $= Just (_circShader pdata)
-- uniform (_uniWinSize pdata) $= Vector2 winx winy
-- uniform (_csZoomUni pdata) $= zoom
-- bindVertexArrayObject $= Just (_vao $ _circVAO pdata)
-- bindArrayBuffers numCircVs $ _vaoBufferTargets $ _circVAO pdata
-- drawArrays Points 0 (fromIntegral $ numCircVs)
---- draw arcs
-- currentProgram $= Just (_arcShader pdata)
-- uniform (_asWinUni pdata) $= Vector2 winx winy
-- uniform (_asZoomUni pdata) $= zoom
-- bindVertexArrayObject $= Just (_vao $ _arcVAO pdata)
-- bindArrayBuffers nArcVs $ _vaoBufferTargets $ _arcVAO pdata
-- drawArrays Points 0 (fromIntegral $ nArcVs)
--
---- reset blend so that light map doesn't apply
-- blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
--
---- draw lines
-- currentProgram $= Just (_basicShader pdata)
-- bindVertexArrayObject $= Just (_vao $ _lineVAO pdata)
-- bindArrayBuffers nTriVs $ _vaoBufferTargets $ _lineVAO pdata
-- drawArrays Lines 0 (fromIntegral $ nLineVs)
---- draw text
-- currentProgram $= Just (_textShader pdata)
-- bindVertexArrayObject $= Just (_vao $ _textVAO pdata)
-- bindArrayBuffers nTextVs $ _vaoBufferTargets $ _textVAO pdata
-- textureBinding Texture2D $= Just (_textures pdata !! 0)
-- drawArrays Points 0 (fromIntegral $ nTextVs)
bufferOffset :: Integral a => a -> Ptr b
bufferOffset = plusPtr nullPtr . fromIntegral
-- the following code draws a picture
-- the following code draws a picture tree
-- it does not set nor change the blend function or depth buffer
renderPicture :: RenderData -> Float -> Float -> (Float,Float) -> (Float,Float)
-> Picture -> IO ()
renderPicture pdata rot zoom (tranx,trany) (winx,winy) pic = do
renderTree :: RenderData -> Float -> Float -> (Float,Float) -> (Float,Float)
-> FTree RenderType -> IO ()
renderTree pdata rot zoom (tranx,trany) (winx,winy) tree = do
-- poke necessary data
(nTriVs,nTextVs,numCircVs,nLineVs,nArcVs)
@@ -357,7 +398,7 @@ renderPicture pdata rot zoom (tranx,trany) (winx,winy) pic = do
(threePtrsVAO $ _circVAO pdata)
(twoPtrsVAO $ _lineVAO pdata)
(threePtrsVAO $ _arcVAO pdata)
) $ picToFTree pic
) $ tree
depthFunc $= Just Less
@@ -392,12 +433,12 @@ renderPicture pdata rot zoom (tranx,trany) (winx,winy) pic = do
drawArrays Points 0 (fromIntegral $ nArcVs)
-- reset blend so that light map doesn't apply
blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
-- blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
-- draw lines
currentProgram $= Just (_basicShader pdata)
bindVertexArrayObject $= Just (_vao $ _lineVAO pdata)
bindArrayBuffers nTriVs $ _vaoBufferTargets $ _lineVAO pdata
bindArrayBuffers nLineVs $ _vaoBufferTargets $ _lineVAO pdata
drawArrays Lines 0 (fromIntegral $ nLineVs)
-- draw text
currentProgram $= Just (_textShader pdata)