diff --git a/Graphics/Rendering/Hieroglyph/Cairo.hs b/Graphics/Rendering/Hieroglyph/Cairo.hs --- a/Graphics/Rendering/Hieroglyph/Cairo.hs +++ b/Graphics/Rendering/Hieroglyph/Cairo.hs @@ -165,7 +165,7 @@ render context images d = loadStateIntoCairo attrs0 >> (foldlM (renderPrimitive context images) attrs0 . sort $ vis) >> return () - where vis = Set.toAscList $ primitives d + where vis = sort $ primitives d attrs0 = attribs . head $ vis applyAttributeDelta a b = do diff --git a/Graphics/Rendering/Hieroglyph/Interactive.hs b/Graphics/Rendering/Hieroglyph/Interactive.hs --- a/Graphics/Rendering/Hieroglyph/Interactive.hs +++ b/Graphics/Rendering/Hieroglyph/Interactive.hs @@ -38,7 +38,7 @@ geom' = scene state' dwin <- Gtk.widgetGetDrawWindow . fromJust . getDrawing $ st Gtk.renderWithDrawable dwin (render context (fromJust (getImageCache st)) geom') - putMVar extant_geometry . Set.toList . primitives $ geom' + putMVar extant_geometry . sort . primitives $ geom' putMVar state state' diff --git a/Graphics/Rendering/Hieroglyph/OpenGL.hs b/Graphics/Rendering/Hieroglyph/OpenGL.hs --- a/Graphics/Rendering/Hieroglyph/OpenGL.hs +++ b/Graphics/Rendering/Hieroglyph/OpenGL.hs @@ -15,6 +15,10 @@ module Graphics.Rendering.Hieroglyph.OpenGL where +import qualified Graphics.UI.Hieroglyph.Cache as Cache +import System.Exit +import GHC.Float +import Data.List import Control.Concurrent import Control.Applicative import Control.Monad.Trans @@ -31,6 +35,8 @@ import qualified Data.Map as Map import qualified Graphics.UI.Gtk as Gtk import qualified Graphics.UI.Gtk.OpenGL as Gtk +import qualified Graphics.UI.Gtk.OpenGL.Drawable as Gtk +import qualified Graphics.UI.Gtk.Gdk.Events as Gtk import qualified Data.ByteString.Internal as SB import qualified Graphics.Rendering.Cairo as Cairo -- for rendering fonts import qualified Graphics.Rendering.OpenGL as GL @@ -44,14 +50,17 @@ import Data.Colour.Names import Data.Colour.SRGB import qualified Text.PrettyPrint as Pretty +import System.Mem.Weak data HieroglyphGLRuntime = HgGL { freetextures :: [GL.TextureObject] , freebuffers :: [GL.BufferObject] , compiledgeometry :: Map.Map GLuint CompiledData , namemap :: Map.Map GLuint String - , window :: Gtk.GLDrawingArea + , drawarea :: Gtk.GLDrawingArea + , window :: Gtk.Window , context ::PangoContext + , imagecache :: Cache.Cache Primitive ([Double],GL.TextureObject) } | Geometry BaseVisual @@ -98,7 +107,6 @@ | CompiledText { attributes :: Attributes , vertices :: [Double] - , texture :: GL.TextureObject , texcoords :: [Double] , uid :: GLuint } @@ -106,7 +114,6 @@ { attributes :: Attributes , vertices :: [Double] , channels :: Int - , bpc :: Int , ww :: Double , hh :: Double , texture :: GL.TextureObject @@ -126,15 +133,10 @@ texturedObjects (CompiledPath _ _ _) = False texturedObjects (CompiledRectangle _ _ _) = False texturedObjects (CompiledText _ _ _ _ _) = True -texturedObjects (CompiledImage _ _ _ _ _ _ _ _ _) = True +texturedObjects (CompiledImage _ _ _ _ _ _ _ _) = True texturedObjects (Optimized _ _ _ (Just _) _ _ _) = True texturedObjects _ = False -freeAllTextures env = env{ compiledgeometry = Map.fromList $ zip liveids live, freetextures = freed } - where (tofree,live) = partition texturedObjects . Map.elems . compiledgeometry $ env - freed = map texture tofree - liveids = map uid live - colourToTuple :: AlphaColour Double -> (Double,Double,Double,Double) colourToTuple c = (r,g,b,alpha) where alpha = alphaChannel c @@ -159,11 +161,11 @@ compile e a@(Text _ _ _ _ _ _ _ _ _ _) = compileText e a compile e a@(Image _ _ _ _ _) = compileImage e a -compileDots e (Dots ds attrs s) = (e, CompiledDots attrs (vdata ds) (fromIntegral s)) +compileDots e (Dots ds attrs s) = (maybe e (\n -> e{ namemap=Map.insert (fromIntegral s) n (namemap e)}) (aname attrs), CompiledDots attrs (vdata ds) (fromIntegral s)) where vdata ((Point x y):vs) = x:y:vdata vs vdata [] = [] -compileArc e (Arc (Point cx cy) r t1 t2 reverse attrs sg) = (e,a0) +compileArc e (Arc (Point cx cy) r t1 t2 reverse attrs sg) = (maybe e (\n -> e{ namemap=Map.insert (fromIntegral sg) n (namemap e)}) (aname attrs),a0) where a0 = CompiledArc attrs (cx : cy : arcVertices 360 @@ -174,7 +176,7 @@ (fromIntegral sg) -compilePath e p = (e, CompiledPath (attribs p) (fillablePath p) (fromIntegral (sig p))) +compilePath e p = (maybe e (\n -> e{ namemap=Map.insert (fromIntegral (sig p)) n (namemap e) }) (aname . attribs $ p) , CompiledPath (attribs p) (fillablePath p) (fromIntegral (sig p))) where fillablePath p = pathOutline' (centroid (begin p:(ls2pt <$> segments p))) (Line (begin p): segments p) pathOutline p = pathOutline' (begin p) (segments p) pathOutline' (Point x0 y0) (Line (Point x1 y1) : ps) = [x0,y0,x1,y1] ++ pathOutline' (Point x1 y1) ps @@ -182,11 +184,21 @@ pathOutline' a (Spline c0 c1 b:ps) = splineVertices 256 a c0 c1 b ++ pathOutline' b ps pathOutline' _ [] = [] -compileRectangle e (Rectangle (Point x y) w h attrs sg) = (e,CompiledRectangle attrs [x, y, x+w, y, x+w, y+h, x, y+h] (fromIntegral sg)) +compileRectangle e (Rectangle (Point x y) w h attrs sg) = (maybe e (\n -> e{ namemap=Map.insert (fromIntegral sg) n (namemap e) }) (aname attrs),CompiledRectangle attrs [x, y, x+w, y, x+w, y+h, x, y+h] (fromIntegral sg)) dataFrom (SB.PS d _ _) = d -compileText e txt = do +nearestPowerOfTwo w h = (log2 $ wf, log2 $ hf) + where log2 x = logDouble x / logDouble 2 + wf = w + hf = h + +compileText e txt + | txt `Cache.member` (imagecache e) = + let (cache',Just (vertexdata, tex)) = Cache.get txt (imagecache e) + e0 = maybe e (\n -> e{ namemap=Map.insert (fromIntegral (sig txt)) n (namemap e) }) (aname . attribs $ txt) + in return (e0{ imagecache=cache' }, CompiledText (attribs txt) vertexdata tex [0,1,1,1,1,0,0,0] (fromIntegral (sig txt))) + | otherwise = do layout <- layoutEmpty (context e) layoutSetMarkup layout . Pretty.render . str $ txt layoutSetAlignment layout . align $ txt @@ -195,54 +207,103 @@ layoutSetWrap layout . wrapmode $ txt layoutSetIndent layout . indent $ txt (PangoRectangle _ _ _ _, PangoRectangle x y w h) <- layoutGetExtents layout - textSurface <- Cairo.withImageSurface Cairo.FormatARGB32 (round w) (round h) $ \surf -> do + let (po2w,po2h) = nearestPowerOfTwo w h + potw = 2 ^ ceiling po2w + poth = 2 ^ ceiling po2h + Point strx stry = bottomleft txt + + -- print ("Power of two ", x,y,w,h, potw,poth) + textSurface <- Cairo.withImageSurface Cairo.FormatARGB32 potw poth $ \surf -> do Cairo.renderWith surf $ do Cairo.setOperator Cairo.OperatorSource - Cairo.rectangle x y w h + Cairo.setSourceRGBA 1 1 1 0 + Cairo.rectangle 0 0 w h Cairo.fill Cairo.setOperator Cairo.OperatorOver Cairo.updateContext (context e) liftIO $ layoutContextChanged layout + Cairo.save + Cairo.translate (-x) (-y) fillStrokeAndClip (attribs txt) $ Cairo.showLayout layout + Cairo.restore + -- Cairo.surfaceWriteToPNG surf "foo.png" Cairo.imageSurfaceGetData surf - let e0 = case freetextures e of - [] -> freeAllTextures e0 - ts -> e0 + let ((_,(_,tex)),imagecache') = Cache.free (imagecache e) + freetextures' = tex:(freetextures e) + e0 = case freetextures e of + [] -> e{ freetextures = freetextures', imagecache = imagecache' } + ts -> e - GL.texture GL.Texture2D $= GL.Enabled + e1 = maybe e0 (\n -> e0{ namemap=Map.insert (fromIntegral (sig txt)) n (namemap e0) }) (aname . attribs $ txt) + GL.textureBinding GL.Texture2D $= Just (head (freetextures e0)) - GL.texImage2D Nothing GL.NoProxy 0 GL.RGBA' (GL.TextureSize2D (round w) (round h)) 0 (GL.PixelData GL.RGBA GL.Double (unsafeForeignPtrToPtr (dataFrom textSurface))) - return ( e0{ freetextures=tail (freetextures e0) } - , CompiledText (attribs txt) [x,y,x+w,y,x+w,y+h,x,y+h] (head (freetextures e0)) [0,0,1,0,1,1,0,1] (fromIntegral (sig txt))) + GL.textureWrapMode GL.Texture2D GL.S $= (GL.Repeated, GL.Clamp) + GL.textureWrapMode GL.Texture2D GL.T $= (GL.Repeated, GL.Clamp) + GL.textureFilter GL.Texture2D $= ((GL.Linear', Nothing), GL.Linear') + GL.textureFunction $= GL.Decal + GL.texImage2D Nothing + GL.NoProxy + 0 + GL.RGBA' + (GL.TextureSize2D (fromIntegral potw) (fromIntegral poth)) + 0 + (GL.PixelData GL.BGRA + GL.UnsignedByte + (unsafeForeignPtrToPtr (dataFrom textSurface))) + return ( e1{ freetextures=tail (freetextures e0) + , imagecache = Cache.put txt ([strx,stry + ,strx+fromIntegral potw + ,stry,strx+fromIntegral potw,stry+fromIntegral poth + ,strx,stry+fromIntegral poth] + ,(head (freetextures e0))) + (imagecache e0) } + , CompiledImage (attribs txt) + [strx,stry + ,strx+fromIntegral potw,stry + ,strx+fromIntegral potw,stry+fromIntegral poth + ,strx,stry+fromIntegral poth] + 3 0 0 + (head (freetextures e0)) + [0,1,1,1,1,0,0,0] + (fromIntegral (sig txt))) + compileImage e img = do - pbuf <- (case dimensions img of - Right (Rect x y w h) -> Gtk.pixbufNewFromFileAtScale (filename img) (round w) (round h) (preserveaspect img) - Left (Point x y) -> Gtk.pixbufNewFromFile (filename img)) - width <- Gtk.pixbufGetWidth pbuf - height <- Gtk.pixbufGetHeight pbuf - channels <- Gtk.pixbufGetNChannels pbuf - bpc <- (`quot`8) <$> Gtk.pixbufGetBitsPerSample pbuf - pixels <- Gtk.pixbufGetPixels pbuf :: IO (Gtk.PixbufData Int Word8) - stride <- Gtk.pixbufGetRowstride pbuf - buffer <- SB.create (width*height*channels*bpc) $ \ptr -> - forM_ [0::Int .. height] $ \row -> let stsample = row*stride in - forM_ [0::Int .. width*channels*bpc] $ \col -> let sample = stsample + col*channels*bpc in - forM_ [0::Int .. channels] $ \channel -> A.readArray pixels (sample+channel) >>= poke ptr - let vertexdata = case dimensions img of - Right (Rect x y w h) -> [x,y,x+w,y,x+w,y+h,x,y+h] - Left (Point x y) -> [x,y,x+fromIntegral width,y,x+fromIntegral width, y+fromIntegral height, x, y+fromIntegral height] + let (cache', cachehit) = Cache.get img (imagecache e) + case cachehit of + Just (vdata, tex) -> return (e{ imagecache=cache' }, CompiledImage (attribs img) vdata 0 0 0 tex [0,1,1,1,1,0,0,0] (fromIntegral (sig img))) + Nothing -> do + (w,h,potw,poth,channels,buffer) <- case dimensions img of + (Left (Point x y)) -> Gtk.pixbufNewFromFile (filename img) >>= copydata + (Right (Rect x y w h)) -> Gtk.pixbufNewFromFileAtScale (filename img) (round w) (round h) (preserveaspect img) >>= copydata + let ((_,(_,tex)),imagecache') = Cache.free (imagecache e) + freetextures' = tex:(freetextures e) + e0 = case freetextures e of + [] -> e{ freetextures = freetextures', imagecache = imagecache' } + ts -> e + GL.textureBinding GL.Texture2D $= Just (head (freetextures e0)) + GL.textureWrapMode GL.Texture2D GL.S $= (GL.Repeated, GL.Clamp) + GL.textureWrapMode GL.Texture2D GL.T $= (GL.Repeated, GL.Clamp) + GL.textureFilter GL.Texture2D $= ((GL.Linear', Nothing), GL.Linear') + GL.textureFunction $= GL.Decal - e0 = case freetextures e of - [] -> freeAllTextures e0 - ts -> e0 + GL.texImage2D Nothing + GL.NoProxy + 0 + (if channels == 4 then GL.RGBA' else GL.RGB') + (GL.TextureSize2D (fromIntegral potw) (fromIntegral poth)) + 0 + (GL.PixelData (if channels == 4 then GL.RGBA else GL.RGB) + GL.UnsignedByte + (unsafeForeignPtrToPtr (dataFrom buffer))) + let vertexdata = case dimensions img of + Left (Point x y) -> [x,y,x+fromIntegral w,y,x+fromIntegral w, y+fromIntegral h, x, y+fromIntegral h] + Right (Rect x y w' h') -> [x,y,x+w',y,x+w',y+h',x,y+h'] - GL.texture GL.Texture2D $= GL.Enabled - GL.textureBinding GL.Texture2D $= Just (head (freetextures e0)) - GL.texImage2D Nothing GL.NoProxy 0 GL.RGBA' (GL.TextureSize2D (fromIntegral width) (fromIntegral height)) 0 (GL.PixelData GL.RGBA GL.Double (unsafeForeignPtrToPtr $ dataFrom buffer)) - return ( e0{ freetextures=tail (freetextures e0) } - , CompiledImage (attribs img) vertexdata channels bpc (fromIntegral width) (fromIntegral height) (head (freetextures e0)) [0,0,1,0,1,1,0,1] (fromIntegral (sig img))) + let e1 = maybe e0 (\n -> e0{ namemap=Map.insert (fromIntegral (sig img)) n (namemap e0) }) (aname . attribs $ img) + return ( e1{ freetextures=tail (freetextures e1) } + , CompiledImage (attribs img) vertexdata channels (fromIntegral w) (fromIntegral h) (head (freetextures e0)) [0,1,1,1,1,0,0,0] (fromIntegral (sig img))) renderCompiledGeometry (CompiledDots attrs vdata iid) = do @@ -257,37 +318,58 @@ renderCompiledGeometry obj@(CompiledPath _ _ _) = (GL.textureBinding GL.Texture2D $= Nothing) >> renderObject obj -renderCompiledGeometry obj@(CompiledRectangle _ _ _) = - (GL.textureBinding GL.Texture2D $= Nothing) >> renderObject obj +renderCompiledGeometry obj@(CompiledRectangle attrs vdata iid) = do + GL.textureBinding GL.Texture2D $= Nothing + loadAttrs attrs + GL.color . colourToGL . afillRGBA . attributes $ obj + when (afilled attrs) . GL.withName (GL.Name iid) . GL.renderPrimitive GL.Quads . mapM_ GL.vertex $ verticesFrom vdata + GL.color . colourToGL . astrokeRGBA . attributes $ obj + when (aoutlined attrs) . GL.withName (GL.Name iid) . GL.renderPrimitive GL.LineStrip $ (mapM_ GL.vertex . verticesFrom $ vdata) >> (GL.vertex . head . verticesFrom $ vdata) + where verticesFrom (x:y:vs) = GL.Vertex2 x y : verticesFrom vs + verticesFrom [] = [] renderCompiledGeometry obj@(CompiledText _ vdata tex txcs iid) = do + -- let (GL.TextureObject tid) = tex in print tid + GL.textureFunction $= GL.Replace + GL.color $ GL.Color4 1 1 1 (1::Double) GL.texture GL.Texture2D $= GL.Enabled GL.textureBinding GL.Texture2D $= Just tex + GL.texture GL.Texture2D $= GL.Enabled + GL.textureFunction $= GL.Replace + GL.withName (GL.Name iid) . GL.renderPrimitive GL.Quads $ do GL.texCoord $ GL.TexCoord2 (txcs !! 0) (txcs !! 1) GL.vertex $ GL.Vertex2 (vdata !! 0) (vdata !! 1) - GL.texCoord $ GL.TexCoord2 (txcs !! 2) (txcs !! 23) - GL.vertex $ GL.Vertex2 (vdata !! 1) (vdata !! 2) - GL.texCoord $ GL.TexCoord2 (txcs !! 3) (txcs !! 4) - GL.vertex $ GL.Vertex2 (vdata !! 3) (vdata !! 4) - GL.texCoord $ GL.TexCoord2 (txcs !! 0) (txcs !! 1) - GL.vertex $ GL.Vertex2 (vdata !! 0) (vdata !! 1) + GL.texCoord $ GL.TexCoord2 (txcs !! 2) (txcs !! 3) + GL.vertex $ GL.Vertex2 (vdata !! 2) (vdata !! 3) + GL.texCoord $ GL.TexCoord2 (txcs !! 4) (txcs !! 5) + GL.vertex $ GL.Vertex2 (vdata !! 4) (vdata !! 5) + GL.texCoord $ GL.TexCoord2 (txcs !! 6) (txcs !! 7) + GL.vertex $ GL.Vertex2 (vdata !! 6) (vdata !! 7) GL.flush -renderCompiledGeometry obj@(CompiledImage _ vdata _ _ w h tex txcs iid) = do + +renderCompiledGeometry obj@(CompiledImage _ vdata _ w h tex txcs iid) = do + -- let (GL.TextureObject tid) = tex in print tid + GL.textureFunction $= GL.Replace + GL.color $ GL.Color4 1 1 1 (1::Double) GL.texture GL.Texture2D $= GL.Enabled GL.textureBinding GL.Texture2D $= Just tex + GL.texture GL.Texture2D $= GL.Enabled + GL.textureFunction $= GL.Replace + GL.withName (GL.Name iid) . GL.renderPrimitive GL.Quads $ do GL.texCoord $ GL.TexCoord2 (txcs !! 0) (txcs !! 1) GL.vertex $ GL.Vertex2 (vdata !! 0) (vdata !! 1) - GL.texCoord $ GL.TexCoord2 (txcs !! 2) (txcs !! 23) - GL.vertex $ GL.Vertex2 (vdata !! 1) (vdata !! 2) - GL.texCoord $ GL.TexCoord2 (txcs !! 3) (txcs !! 4) - GL.vertex $ GL.Vertex2 (vdata !! 3) (vdata !! 4) - GL.texCoord $ GL.TexCoord2 (txcs !! 0) (txcs !! 1) - GL.vertex $ GL.Vertex2 (vdata !! 0) (vdata !! 1) + GL.texCoord $ GL.TexCoord2 (txcs !! 2) (txcs !! 3) + GL.vertex $ GL.Vertex2 (vdata !! 2) (vdata !! 3) + GL.texCoord $ GL.TexCoord2 (txcs !! 4) (txcs !! 5) + GL.vertex $ GL.Vertex2 (vdata !! 4) (vdata !! 5) + GL.texCoord $ GL.TexCoord2 (txcs !! 6) (txcs !! 7) + GL.vertex $ GL.Vertex2 (vdata !! 6) (vdata !! 7) GL.flush + renderCompiledGeometry obj@(Optimized attrs vbo tbo tex iid startindex len) = do GL.bindBuffer GL.ArrayBuffer $= Just vbo GL.arrayPointer GL.VertexArray $= GL.VertexArrayDescriptor 2 GL.Double 0 nullPtr @@ -307,11 +389,11 @@ GL.color . colourToGL . afillRGBA . attributes $ obj GL.withName (GL.Name (uid obj)) . GL.renderPrimitive GL.TriangleFan . mapM_ GL.vertex . verticesFrom $ vertices obj GL.color . colourToGL . astrokeRGBA . attributes $ obj - when (aoutlined (attributes obj)) $ (GL.withName (GL.Name (uid obj)) . GL.renderPrimitive GL.Lines . mapM_ GL.vertex . verticesFrom . drop 2 $ vertices obj) + when (aoutlined (attributes obj)) $ (GL.withName (GL.Name (uid obj)) . GL.renderPrimitive GL.LineStrip . mapM_ GL.vertex . verticesFrom . drop 2 $ vertices obj) | otherwise = GL.preservingMatrix $ do loadAttrs (attributes obj) GL.color . colourToGL . astrokeRGBA . attributes $ obj - GL.withName (GL.Name (uid obj)) . GL.renderPrimitive GL.Lines . mapM_ GL.vertex . verticesFrom . drop 2 $ vertices obj + GL.withName (GL.Name (uid obj)) . GL.renderPrimitive GL.LineStrip . mapM_ GL.vertex . verticesFrom . drop 2 $ vertices obj where verticesFrom (x:y:vs) = GL.Vertex2 x y : verticesFrom vs verticesFrom [] = [] @@ -350,7 +432,7 @@ , lod :: Int -- ^ The level of detail that this primitive is at. Use Graphics.Rendering.Hieroglyph.Visual.moreSpecific } -} -loadAttrs attrs = do +loadAttrs attrs = GL.preservingMatrix $ do GL.lineWidth $= (realToFrac . alinewidth $ attrs) GL.matrixMode $= GL.Modelview 0 GL.loadIdentity @@ -375,25 +457,46 @@ -- * add any other state variables we want to check on to save time. -- * add lookup tables for geometry. -- * add weak table for optimized geometry. -initializeBus bus = do - b <- takeMVar bus +initializeBus name w h bus = do +-- b <- takeMVar bus -- let numTexturesE = Buster.topEvent . Buster.eventsFor (Just "Environment") Nothing (Just "numTextures") $ b -- numBufferObjectsE = Buster.topEvent . Buster.eventsFor (Just "Environment") Nothing (Just "numBufferObjects") $ b -- Buster.EInt numTextures = head . Buster.eventdata $ numTexturesE -- Buster.EInt numBufferObjects = head . Buster.eventdata $ numBufferObjectsE +-- putMVar bus b - let numTextures = 128 + let numTextures = 400 numBufferObjects = 1 - + Gtk.unsafeInitGUIForThreadedRTS + win <- Gtk.windowNew + Gtk.windowSetTitle win name + Gtk.widgetSetName win "Hieroglyph" + Gtk.onDestroy win (exitWith ExitSuccess) Gtk.initGL - config <- Gtk.glConfigNew [Gtk.GLModeRGBA, Gtk.GLModeMultiSample, Gtk.GLModeDouble, Gtk.GLModeAlpha, Gtk.GLModeMultiSample] + config <- Gtk.glConfigNew [Gtk.GLModeRGBA, {- Gtk.GLModeMultiSample, -} Gtk.GLModeDouble, Gtk.GLModeAlpha] area <- Gtk.glDrawingAreaNew config - textures <- (GL.genObjectNames numTextures) :: IO [GL.TextureObject] - buffers <- (GL.genObjectNames numBufferObjects) :: IO [GL.BufferObject] + + Gtk.onRealize area $ do + GL.drawBuffer $= GL.BackBuffers + + Gtk.windowSetDefaultSize win w h + Gtk.containerResizeChildren win + Gtk.containerAdd win area + Gtk.widgetShowAll win + (textures, buffers) <- Gtk.withGLDrawingArea area $ \_ -> do + ts <- (GL.genObjectNames numTextures) :: IO [GL.TextureObject] + bs <- (GL.genObjectNames numBufferObjects) :: IO [GL.BufferObject] + return (ts,bs) + context <- Gtk.cairoCreateContext Nothing - let edata = HgGL textures buffers Map.empty Map.empty area context + + let edata = HgGL textures buffers Map.empty Map.empty area win context ( Cache.empty 1024768000 0) Buster.produce' "Hieroglyph" "Hieroglyph" "RenderData" Buster.Persistent [Buster.EOther edata] bus + Gtk.onExpose area (\_ -> renderOnExpose bus >> return True) + return () + -- print "bus initialized" + -- a behaviour to actually render hieroglyph data. -- On a separate thread and using STM: -- * get the lookup tables for geometry and optimized geometry. @@ -417,66 +520,114 @@ (p, GL.Size sx sy ) <- GL.get GL.viewport GL.matrixMode $= GL.Projection GL.loadIdentity - GL.pickMatrix (selx-2, sely-2) (6,6) (p, GL.Size sx sy) - GL.ortho2D 0 (fromIntegral sx) (fromIntegral sy) 0 - (runtime', recs) <- GL.getHitRecords 5 $ renderObjects (Set.toList drawing) runtime - selectionEvents <- mapM hr2event (fromMaybe [] recs) + GL.pickMatrix (selx-2, (fromIntegral sy)-sely+2) (6,6) (p, GL.Size sx sy) + GL.ortho2D 0 (fromIntegral sx) 0 (fromIntegral sy) + (runtime', recs) <- GL.getHitRecords 5 $ renderObjects (sort drawing) runtime + selectionEvents <- forM (fromMaybe [] recs) $ \(GL.HitRecord x y names) -> + let names' = (fromMaybe "" . ((flip Map.lookup) (namemap runtime')) . (\(GL.Name x) -> x)) <$> names in + Buster.produce "Selection" "Hieroglyph" (concat names') Buster.once + [Buster.EDouble . realToFrac $ x + , Buster.EDouble . realToFrac $ y + , Buster.EStringL $ names'] + runtimeE' <- Buster.produce "Hieroglyph" "Hieroglyph" "RenderData" Buster.Persistent [Buster.EOther runtime'] - Buster.future . return $ [Buster.Deletion sreq , Buster.Deletion runtimeE , runtimeE'] ++ selectionEvents - Nothing -> Buster.future . return $ [] + Buster.future bus . return $ [Buster.Deletion sreq , runtimeE'] ++ selectionEvents + + Nothing -> Buster.future bus . return $ [] where runtimeE = fromJust $ Buster.eventByQName "Hieroglyph" "Hieroglyph" "RenderData" bus Buster.EOther runtime = head . Buster.eventdata $ runtimeE - drawing = primitives . map (\(Buster.EOther (Geometry x)) -> x) . concat . map Buster.eventdata . filter ((=="Geometry") . Buster.name) $ drawingEs - drawingEs = Set.toList $ Buster.eventsByGroup "Heiroglyph" bus + drawing = primitives . map (\(Buster.EOther (Geometry x)) -> x) . concat . map Buster.eventdata $ drawingEs + drawingEs = Set.toList $ Buster.eventsByGroup "Visible" bus selectionRequested = Buster.eventByQName "Hieroglyph" "Hieroglyph" "PleaseSelect" bus - hr2event (GL.HitRecord x y names) = Buster.produce "Selection" "Hieroglyph" (show (x,y)) Buster.once [Buster.EDouble . realToFrac $ x, Buster.EDouble . realToFrac $ y, Buster.EStringL $ (fromMaybe "" . ((flip Map.lookup) (namemap runtime)) . (\(GL.Name x) -> x)) <$> names] -renderBehaviour bus = - case renderRequested of - Just rreq -> do runtime' <- render runtime drawing - revent' <- Buster.produce "Hieroglyph" "Hieroglyph" "RenderData" Buster.Persistent [Buster.EOther runtime'] - Buster.future . return $ [Buster.Deletion runtimeE , Buster.Deletion rreq, revent'] - Nothing -> Buster.future . return $ [] - where runtimeE = fromJust $ Buster.eventByQName "Hieroglyph" "Hieroglyph" "RenderData" bus - Buster.EOther runtime = head . Buster.eventdata $ runtimeE - drawing = primitives . map (\(Buster.EOther (Geometry x)) -> x) . concat . map Buster.eventdata . filter ((=="Geometry") . Buster.name) $ drawingEs - drawingEs = Set.toList $ Buster.eventsByGroup "Heiroglyph" bus - renderRequested = Buster.eventByQName "Hieroglyph" "Hieroglyph" "PleaseRender" bus -render runtime@(HgGL _ _ _ _ win _) geo = do - (GL.Position _ _, GL.Size sx sy ) <- GL.get GL.viewport +renderOnExpose busV = do + bus <- takeMVar busV + putMVar busV bus + let runtimeE = fromJust $ Buster.eventByQName "Hieroglyph" "Hieroglyph" "RenderData" bus + Buster.EOther runtime = head . Buster.eventdata $ runtimeE + drawing = primitives . map (\(Buster.EOther (Geometry x)) -> x) . concat . map Buster.eventdata $ drawingEs + drawingEs = Set.toList $ Buster.eventsByGroup "Visible" bus + + -- print . map (aname . attribs) $ drawing + + --putStrLn "Drawables:" + --mapM (print . Buster.showQName) drawingEs + -- putStrLn "" + -- print "expose event" + runtime' <- render runtime drawing + Buster.Insertion revent' <- Buster.produce "Hieroglyph" "Hieroglyph" "RenderData" Buster.Persistent [Buster.EOther runtime] + takeMVar busV + let bus' = Buster.addEvent revent' bus + putMVar busV bus' + +renderBehaviour bus = Buster.consumeFullyQualifiedEventWith bus "Hieroglyph" "Hieroglyph" "Rerender" $ \event -> do + let Buster.EOther renderdata = head . Buster.eventdata . fromJust $ Buster.eventByQName "Hieroglyph" "Hieroglyph" "RenderData" bus + (w,h) <- Gtk.widgetGetSize (window renderdata) + Gtk.widgetQueueDrawArea (window renderdata) 0 0 w h + return [] + +render runtime@(HgGL _ _ _ _ win _ _ _) geo = Gtk.withGLDrawingArea win $ \drawable -> do + -- print "rendering" + GL.drawBuffer $= GL.BackBuffers + (GL.Position px py, GL.Size sx sy ) <- GL.get GL.viewport + -- print (px,py) + -- print (sx,sy) GL.matrixMode $= GL.Projection GL.loadIdentity - GL.ortho2D 0 (fromIntegral sx) (fromIntegral sy) 0 - GL.clearColor $= GL.Color4 0 0 0 1 + GL.ortho2D 0 (fromIntegral sx) 0 (fromIntegral sy) + GL.clearColor $= GL.Color4 1 1 1 1 GL.clear [GL.ColorBuffer] GL.blend $= GL.Enabled - GL.blendFunc $= (GL.SrcColor, GL.OneMinusSrcColor) - r' <- renderObjects (Set.toList geo) runtime - drawable <- Gtk.toGLDrawable <$> Gtk.glDrawingAreaGetGLWindow win + GL.blendFunc $= (GL.SrcAlpha, GL.OneMinusSrcAlpha) + GL.lineSmooth $= GL.Enabled + GL.polygonSmooth $= GL.Enabled + r' <- renderObjects (sort geo) runtime + -- print "finished rednering objects" Gtk.glDrawableSwapBuffers drawable + -- print "swapped buffers" return r' -renderObjects (o:os) !r = renderObj o r >>= renderObjects os +renderObjects (o:os) !r = {- print o >> -} renderObj o r >>= renderObjects os renderObjects [] r = return r renderObj :: Primitive -> HieroglyphGLRuntime -> IO HieroglyphGLRuntime -renderObj obj runtime = - if (fromIntegral . sig $ obj) `Map.member` (compiledgeometry runtime) - then do - renderCompiledGeometry $ (compiledgeometry runtime) Map.! (fromIntegral . sig $ obj) - return runtime - else do +renderObj obj runtime = do + -- print (aname . attribs $ obj) (runtime',cg0) <- compile runtime obj + -- print "compiled" renderCompiledGeometry cg0 - return runtime'{ compiledgeometry = Map.insert (uid cg0) cg0 . compiledgeometry $ runtime', namemap=Map.insert (uid cg0) (fromMaybe "" . aname . attributes $ cg0) (namemap runtime') } - - - + return runtime'{ compiledgeometry = Map.insert (uid cg0) cg0 . compiledgeometry $ runtime' + , namemap=Map.insert (uid cg0) + (fromMaybe "" . aname . attributes $ cg0) + (namemap runtime') + } +{-# INLINE copydata #-} +copydata pbuf0 = do + w0 <- Gtk.pixbufGetWidth pbuf0 + h0 <- Gtk.pixbufGetHeight pbuf0 + let potw = log (fromIntegral w0) / log (fromIntegral 2) + poth = log (fromIntegral h0) / log (fromIntegral 2) + w = 2 ^ ceiling potw + h = 2 ^ ceiling poth + pbuf <- if w0 == w && h0 == h then return pbuf0 else Gtk.pixbufScaleSimple pbuf0 w h Gtk.InterpBilinear + channels <- Gtk.pixbufGetNChannels pbuf + bpc <- (`quot`8) <$> Gtk.pixbufGetBitsPerSample pbuf + pixels <- Gtk.pixbufGetPixels pbuf :: IO (Gtk.PixbufData Int Word8) + stride <- Gtk.pixbufGetRowstride pbuf + buf <- SB.create (w*h*channels*bpc) $ \ptr -> + forM_ [0::Int .. h - 1] $ \row -> let stsample = row*stride in + forM_ [0::Int .. w*channels*bpc-1] $ \sample0 -> let sample = stsample + sample0 in + A.readArray pixels sample >>= pokeByteOff ptr sample + return (w0,h0,w,h,channels,buf) +mouseSelectionBehaviour bus = Buster.pollFullyQualifiedEventWith bus "Mouse" "Hierolgyph.KeyboardMouseWidget" "SingleClick" $ \event -> do + let (Buster.EAssocL alist) = head . Buster.eventdata $ event + (Buster.EDoubleL (x:y:_)) = fromJust $ "coords" `lookup` alist + Buster.listM $ Buster.produce "Hieroglyph" "Hieroglyph" "PleaseSelect" Buster.once [Buster.EDouble x, Buster.EDouble y] diff --git a/Graphics/Rendering/Hieroglyph/Primitives.hs b/Graphics/Rendering/Hieroglyph/Primitives.hs --- a/Graphics/Rendering/Hieroglyph/Primitives.hs +++ b/Graphics/Rendering/Hieroglyph/Primitives.hs @@ -25,7 +25,7 @@ import Data.Colour import Data.Colour.Names import Data.Colour.SRGB ---import Data.Foldable + import qualified Data.Map as Map import qualified Data.IntMap as IM import Text.PrettyPrint (Doc, (<>), (<+>), render, char, empty, text) @@ -224,8 +224,9 @@ , aclipped :: Bool -- ^ Whether or not this primitive is part of the clipping plane , layer :: Int -- ^ This sorts out which primitives are located on top of each other. Do not set this yourself. Use Graphics.Rendering.Hieroglyph.Visual.over , bbox :: Rect -- ^ The clockwise rotation in radians. - , aname :: Maybe String -- ^ The name of the object + , aname :: Maybe String -- ^ The name of the object , lod :: Int -- ^ The level of detail that this primitive is at. Use Graphics.Rendering.Hieroglyph.Visual.moreSpecific + , updated :: Bool } deriving (Show,Read,Eq) @@ -239,8 +240,42 @@ -- | define a total ordering over the primitives based on layer and rendering cost instance Ord Primitive where - compare a b = let cmp = (attribs %=> compare) a b in if cmp == EQ then (sig %=> compare) a b else cmp + compare a b = + case (cmpattrs, cmpsigs, cmpprims) of + (EQ, EQ, x) -> x + (EQ, x, _) -> x + (x, _, _) -> x + where cmpattrs = (attribs %=> compare) a b + cmpsigs = (sig %=> compare) a b + cmpprims = comparePrimitives a b +comparePrimitives (Dots ats0 _ _) (Dots ats1 _ _) = maybe EQ (uncurry compare) $ find (\(a,b) -> a /= b) (zip ats0 ats1) +comparePrimitives (Arc c r a1 a2 _ _ _) (Arc c' r' a1' a2' _ _ _) = fromMaybe EQ (find (/=EQ) [compare c c', compare r r', compare a1 a1', compare a2 a2']) +comparePrimitives (Path beg segs _ _ _) (Path beg' segs' _ _ _) = fromMaybe EQ (find (/=EQ) (compare beg beg' : compare (length segs) (length segs') : map (uncurry compareSegment) (zip segs segs'))) + where compareSegment (Line a) (Line b) = compare a b + compareSegment (Spline a a1 a2) (Spline b b1 b2) = fromMaybe EQ (find (/=EQ) [compare a b, compare a1 b1, compare a2 b2]) + compareSegment (EndPoint a) (EndPoint b) = compare a b + compareSegment a b = compare (lineordering a) (lineordering b) + lineordering (Line _) = 0 + lineordering (Spline _ _ _) = 1 + lineordering (EndPoint _) = 2 +comparePrimitives (Rectangle o w h _ _) (Rectangle o' w' h' _ _) = fromMaybe EQ (find (/=EQ) [compare o o', compare w w', compare h h']) +comparePrimitives (Text s b _ _ _ _ _ _ _ _) (Text s' b' _ _ _ _ _ _ _ _) = fromMaybe EQ (find (/=EQ) [compare s s', compare b b']) +comparePrimitives (Union p _ _) (Union p' _ _) = fromMaybe EQ . find (/=EQ) . map (uncurry compare) $ zip p p' +comparePrimitives (Image f d p _ _) (Image f' d' p' _ _) = fromMaybe EQ . find (/=EQ) $ [compare f f', compare d d', compare p p'] +comparePrimitives a b = compare (primitiveOrdering a) (primitiveOrdering b) + +-- comparePrimitives (Text _ _ _ _ _ _ _ _ _ _) (Text _ _ _ _ _ _ _ _ _ _) = + +primitiveOrdering (Dots _ _ _) = 0 +primitiveOrdering (Arc _ _ _ _ _ _ _) = 1 +primitiveOrdering (Path _ _ _ _ _) = 2 +primitiveOrdering (Rectangle _ _ _ _ _) = 3 +primitiveOrdering (Text _ _ _ _ _ _ _ _ _ _) = 4 +primitiveOrdering (Union _ _ _) = 5 +primitiveOrdering (Image _ _ _ _ _) = 6 +primitiveOrdering (Hidden _ _) = 7 + -- | See the Cairo meanings of these. I plan to introduce OpenGL equivalents data Antialias = AntialiasDefault @@ -313,11 +348,12 @@ , bbox = Plane , layer = 0 , lod = 0 - , aname = Nothing } + , aname = Nothing + , updated = True } -- | following combinators added to Text.PrettyPrint -span a s = mark ("span " ++ a) s +tspan a s = text " text a <> char '>' <> s <> text "" mark m d = char '<' <> text m <> char '>' <> d <> text " text m <> char '>' bold = mark "b" @@ -354,7 +390,7 @@ rectangle = sign $ Rectangle (Point 0 1) 1 1 plain 0 string :: Primitive -- ^ A rendered string starting at the origin. -string = sign $ Text empty origin AlignLeft (Just 0) WrapWholeWords False 0 plain 0 0 +string = sign $ Text empty origin AlignLeft Nothing WrapWholeWords False 0 plain{ afilled=True } 0 0 compound :: Primitive -- ^ An outlined compound object compound = sign $ Union [] plain 0 diff --git a/Graphics/Rendering/Hieroglyph/Visual.hs b/Graphics/Rendering/Hieroglyph/Visual.hs --- a/Graphics/Rendering/Hieroglyph/Visual.hs +++ b/Graphics/Rendering/Hieroglyph/Visual.hs @@ -14,7 +14,7 @@ import Data.List import Graphics.Rendering.Hieroglyph.Primitives -type BaseVisual = S.Set Primitive +type BaseVisual = [Primitive] -- | A Visual is an unstructured collection of primitives. Conceptually, the -- only requirement of a Visual is that it is Enumerable (or Foldable) in @@ -29,12 +29,12 @@ -- | A Primitive by itself is a Visual. That is, a single piece of geometry -- standing alone is in fact Visual. instance Visual Primitive where - primitives a = S.singleton a + primitives a = [a] -- | A any list of Visuals can be flattenend into a list of Primitives by -- a right fold, therefore a List of Visuals is a Visual instance Visual a => Visual [a] where - primitives x = mconcat $ primitives `map` x + primitives x = concat $ primitives `map` x -- | A map to Visuals is Foldable over the elements in terms of Visuals, which -- are in turn Foldable in terms of Primitives, therefore a map of @@ -52,17 +52,17 @@ -- | Declare that a Visual possibly occludes another Visual occludes :: (Visual t, Visual u) => t -> u -> BaseVisual -occludes this that = ((\p -> p{ layer = maxlev+1 }) <%> primitives this) `mappend` (primitives that) - where maxlev = maximum . map (layer . attribs) . S.toList . primitives $ that +occludes this that = ((\p -> p{ layer = maxlev+1 }) <%> primitives this) ++ (primitives that) + where maxlev = maximum . map (layer . attribs) . primitives $ that beside :: (Visual t, Visual u) => t -> u -> BaseVisual -beside this that = ((\p -> p{ layer = maxlev }) <%> primitives this) `mappend` (primitives that) - where maxlev = maximum . map (layer . attribs) . S.toList . primitives $ that +beside this that = ((\p -> p{ layer = maxlev }) <%> primitives this) ++ (primitives that) + where maxlev = maximum . map (layer . attribs) . primitives $ that -pure x = S.singleton x +pure x = [x] -f <%> x = S.map (\a -> a{ attribs = (f . attribs $ a)}) x -(#+#) = beside +f <%> x = map (\a -> a{ attribs = (f . attribs $ a)}) x +(#+#) = (++) (#/#) = occludes (#\#) = flip occludes @@ -90,5 +90,7 @@ outlined x os = (\o -> o{aoutlined = x}) <%> primitives os clipped x os = (\o -> o{aclipped = x}) <%> primitives os name x os = (\o -> o{aname = Just x}) <%> primitives os +cached x os = (\o -> o{updated = False}) <%> primitives os +fresh x os = (\o -> o{updated = True}) <%> primitives os diff --git a/Graphics/UI/Hieroglyph/Cache.hs b/Graphics/UI/Hieroglyph/Cache.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/Hieroglyph/Cache.hs @@ -0,0 +1,58 @@ +----------------------------------------------------------------------------- +-- +-- Module : Graphics.UI.Hieroglyph.Cache +-- Copyright : +-- License : BSD3 +-- +-- Maintainer : J.R. Heard +-- Stability : +-- Portability : +-- +-- | +-- +----------------------------------------------------------------------------- + +module Graphics.UI.Hieroglyph.Cache where + +import qualified Data.Map as Map +import qualified Data.IntMap as IntMap + +data Cache k a = Cache { store :: Map.Map k a, times :: IntMap.IntMap k, now :: Int, maxsize :: Int, size :: Int, decimation :: Int } + +empty mxsz dec = Cache Map.empty IntMap.empty 0 mxsz 0 dec + +get :: Ord k => k -> Cache k a -> (Cache k a,Maybe a) +get key cache = (cache',value) + where value = Map.lookup key (store cache) + cache' = maybe (cache{ now = now cache + 1 }) (\_ -> cache{ now = now cache + 1, times = IntMap.insert (now cache) key (times cache) }) value + +put :: Ord k => k -> a -> Cache k a -> Cache k a +put key value cache + | size cache < maxsize cache && (not $ Map.member key (store cache)) = cache { now = now cache + 1, times = IntMap.insert (now cache) key (times cache), store = Map.insert key value (store cache) , size = size cache + 1 } + | size cache < maxsize cache = cache { now = now cache + 1, times = IntMap.insert (now cache) key (times cache), store = Map.insert key value (store cache) } + | size cache >= maxsize cache && (Map.member key (store cache)) = cache { now = now cache + 1, times = IntMap.insert (now cache) key (times cache), store = Map.insert key value (store cache) } + | size cache >= maxsize cache = cache{ now = now cache + 1, times = IntMap.insert (now cache) key times', store = Map.insert key value store', size = size cache - decimation cache } + where times' = foldr IntMap.delete (times cache) lowtimes + (lowtimes,lowtimekeys) = unzip . take (decimation cache) . IntMap.toAscList . times $ cache + store' = foldr Map.delete (store cache) lowtimekeys + +put' :: Ord k => k -> a -> Cache k a -> ([a], Cache k a) +put' key value cache + | size cache < maxsize cache && (not $ Map.member key (store cache)) = ([],cache { now = now cache + 1, times = IntMap.insert (now cache) key (times cache), store = Map.insert key value (store cache) , size = size cache + 1 }) + | size cache < maxsize cache = ([],cache { now = now cache + 1, times = IntMap.insert (now cache) key (times cache), store = Map.insert key value (store cache) }) + | size cache >= maxsize cache && (Map.member key (store cache)) = ([],cache { now = now cache + 1, times = IntMap.insert (now cache) key (times cache), store = Map.insert key value (store cache) }) + | size cache >= maxsize cache = (freed, cache{ now = now cache + 1, times = IntMap.insert (now cache) key times', store = Map.insert key value store', size = size cache - decimation cache }) + where times' = foldr IntMap.delete (times cache) lowtimes + (lowtimes,lowtimekeys) = unzip . take (decimation cache) . IntMap.toAscList . times $ cache + store' = foldr Map.delete (store cache) lowtimekeys + freed = map (store cache Map.!) lowtimekeys + +free :: Ord k => Cache k a -> ((k,a),Cache k a) +free cache = ((minkey,minval),cache') + where minkey = IntMap.findMin (times cache) + minval = store cache Map.! minkey + cache' = cache{ now = now cache + 1, times = IntMap.deleteMin (times cache), store = Map.delete minkey (store cache), size = (size cache) } + +member :: Ord k => k -> Cache k a -> Bool +member key cache = Map.member key (store cache) + diff --git a/Hieroglyph.cabal b/Hieroglyph.cabal --- a/Hieroglyph.cabal +++ b/Hieroglyph.cabal @@ -1,13 +1,13 @@ name: Hieroglyph -version: 2.10 +version: 2.21 cabal-version: >=1.2 build-type: Simple license: BSD3 license-file: LICENSE copyright: maintainer: J.R. Heard -build-depends: FTGL -any, IfElse -any, OpenGL -any, array -any, - base -any, buster -any, bytestring -any, cairo -any, colour -any, +build-depends: IfElse -any, OpenGL -any, array -any, + base -any, buster >=2.0, bytestring -any, cairo -any, colour -any, containers -any, gtk -any, gtkglext -any, mtl -any, parallel -any, pretty -any, random -any stability: @@ -24,8 +24,8 @@ data-dir: "" extra-source-files: extra-tmp-files: -exposed-modules: Graphics.Rendering.Hieroglyph - Graphics.Rendering.Hieroglyph.Cairo +exposed-modules: Graphics.UI.Hieroglyph.Cache + Graphics.Rendering.Hieroglyph Graphics.Rendering.Hieroglyph.Cairo Graphics.Rendering.Hieroglyph.OpenGL Graphics.Rendering.Hieroglyph.ImageCache Graphics.Rendering.Hieroglyph.Interactive