Hieroglyph 2.10 → 2.21
raw patch · 7 files changed
+381/−134 lines, 7 filesdep −FTGLdep ~buster
Dependencies removed: FTGL
Dependency ranges changed: buster
Files
- Graphics/Rendering/Hieroglyph/Cairo.hs +1/−1
- Graphics/Rendering/Hieroglyph/Interactive.hs +1/−1
- Graphics/Rendering/Hieroglyph/OpenGL.hs +262/−111
- Graphics/Rendering/Hieroglyph/Primitives.hs +42/−6
- Graphics/Rendering/Hieroglyph/Visual.hs +12/−10
- Graphics/UI/Hieroglyph/Cache.hs +58/−0
- Hieroglyph.cabal +5/−5
Graphics/Rendering/Hieroglyph/Cairo.hs view
@@ -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
Graphics/Rendering/Hieroglyph/Interactive.hs view
@@ -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'
Graphics/Rendering/Hieroglyph/OpenGL.hs view
@@ -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]
Graphics/Rendering/Hieroglyph/Primitives.hs view
@@ -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 "<span " <> text a <> char '>' <> s <> text "</span>" 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
Graphics/Rendering/Hieroglyph/Visual.hs view
@@ -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
+ Graphics/UI/Hieroglyph/Cache.hs view
@@ -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)+
Hieroglyph.cabal view
@@ -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