diff --git a/src/Dodge/Rendering.hs b/src/Dodge/Rendering.hs index 25961a1ea..fbcb34597 100644 --- a/src/Dodge/Rendering.hs +++ b/src/Dodge/Rendering.hs @@ -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 diff --git a/src/Picture.hs b/src/Picture.hs index e9ea60bfd..e0fff3a36 100644 --- a/src/Picture.hs +++ b/src/Picture.hs @@ -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 diff --git a/src/Picture/Data.hs b/src/Picture/Data.hs index 621558cc2..72dd5f5cc 100644 --- a/src/Picture/Data.hs +++ b/src/Picture/Data.hs @@ -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 #-} diff --git a/src/Picture/Render.hs b/src/Picture/Render.hs index 769477622..805c92870 100644 --- a/src/Picture/Render.hs +++ b/src/Picture/Render.hs @@ -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)