Hieroglyph 3.1 → 3.2
raw patch · 7 files changed
+86/−72 lines, 7 files
Files
- Graphics/Rendering/Hieroglyph/Cairo.hs +11/−1
- Graphics/Rendering/Hieroglyph/OpenGL.hs +5/−5
- Graphics/Rendering/Hieroglyph/OpenGL/Compile.hs +55/−42
- Graphics/Rendering/Hieroglyph/OpenGL/Render.hs +9/−19
- Graphics/Rendering/Hieroglyph/Primitives.hs +4/−3
- Graphics/Rendering/Hieroglyph/Visual.hs +1/−1
- Hieroglyph.cabal +1/−1
Graphics/Rendering/Hieroglyph/Cairo.hs view
@@ -33,6 +33,7 @@ import Data.Colour.SRGB import Data.Colour.Names (black) import qualified Text.PrettyPrint as Pretty+import Data.Maybe type ImageCache = MVar (Cache.Cache Primitive Pixbuf) @@ -134,7 +135,8 @@ fillStrokeAndClip state $ Cairo.rectangle ox oy w h return state -renderPrimitive context _ s0 txt@(Text _ (Point ox oy) _ _ _ _ _ _ _ _) = do+renderPrimitive context _ s0 txt@(Text _ (Point ox oy) _ _ _ _ _ _ _ _ bg) = do+ Cairo.save layout <- liftIO $ layoutEmpty context >>= \layout -> do layoutSetMarkup layout . Pretty.render . str $ txt layoutSetAlignment layout . align $ txt@@ -144,9 +146,17 @@ layoutSetIndent layout . indent $ txt return layout applyAttributeDelta s0 (attribs txt)+ if isJust (backgroundcolour txt)+ then do (PangoRectangle _ _ lw lh, _) <- liftIO (layoutGetExtents layout)+ let (br,bg,bb,ba) = colourToTuple (fromJust $ backgroundcolour txt) in Cairo.setSourceRGBA br bg bb ba+ Cairo.rectangle ox oy (lw+2) (lh+2)+ Cairo.fill+ Cairo.translate 2 2+ else return () fillStrokeAndClip (attribs txt) $ do Cairo.moveTo ox oy Cairo.showLayout layout+ Cairo.restore return (attribs txt) renderPrimitive context images s0 (Union prims state _) = do
Graphics/Rendering/Hieroglyph/OpenGL.hs view
@@ -13,7 +13,7 @@ -- ----------------------------------------------------------------------------- -module Graphics.Rendering.Hieroglyph.OpenGL +module Graphics.Rendering.Hieroglyph.OpenGL ( module Graphics.Rendering.Hieroglyph.OpenGL.Data , mouseSelectionBehaviour , boilerplateOpenGLMain@@ -114,7 +114,7 @@ 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 + Gtk.widgetQueueDrawArea (window renderdata) 0 0 w h return $ [] @@ -134,8 +134,8 @@ GL.ortho 0 (fromIntegral sx) 0 (fromIntegral sy) 1 2 (runtime', recs) <- GL.getHitRecords 16 $ renderObjects [1::Double,2..] (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 do - Buster.produce "Selection" "Hieroglyph" (concat names') Buster.once+ let names' = (fromMaybe "" . ((flip Map.lookup) (namemap runtime')) . (\(GL.Name x) -> x)) <$> names in do+ Buster.produce "Selection" "Hieroglyph" (unlines names') Buster.once [Buster.EDouble . realToFrac $ x , Buster.EDouble . realToFrac $ y , Buster.EStringL $ names']@@ -155,7 +155,7 @@ -- | Widget for initializing the bus initializeBus :: String -> Int -> Int -> Buster.Widget [Buster.EData HieroglyphGLRuntime] initializeBus name w h bus = do- let numTextures = 512 + let numTextures = 512 numBufferObjects = 256 Gtk.unsafeInitGUIForThreadedRTS
Graphics/Rendering/Hieroglyph/OpenGL/Compile.hs view
@@ -54,6 +54,9 @@ import Data.Colour.SRGB import qualified Text.PrettyPrint as Pretty import System.Mem.Weak+import Control.Exception+import Debug.Trace+ arcFn _ _ _ [] = [] arcFn x y r (t:ts) = (x + r * cos t) : (y + r * sin t) : arcFn x y r ts arcVertices nvertices (Point cx cy) r t1 t2 = arcFn cx cy r $ [t1+t | t <- [0,(t2-t1)/nvertices..t2-t1]]@@ -75,12 +78,12 @@ where xs = cubic ax c0x c1x bx [m / nvertices' | m <- [0 .. nvertices']] ys = cubic ay c0y c1y by [m / nvertices' | m <- [0 .. nvertices']] nvertices' = (fromIntegral nvertices) :: Double- + compile e a@(Dots _ _ _) = return $ compileDots e a compile e a@(Arc _ _ _ _ _ _ _) = return $ compileArc e a compile e a@(Path _ _ _ _ _ ) = return $ compilePath e a compile e a@(Rectangle _ _ _ _ _) = return $ compileRectangle e a-compile e a@(Text _ _ _ _ _ _ _ _ _ _) = compileText e a+compile e a@(Text _ _ _ _ _ _ _ _ _ _ _) = compileText e a compile e a@(Image _ _ _ _ _) = compileImage e a compileDots e p@(Dots ds attrs s) = (maybe e (\n -> e{ namemap=Map.insert (fromIntegral s) n (namemap e)}) (aname attrs), CompiledDots p (vdata ds) (fromIntegral s))@@ -104,7 +107,7 @@ , CompiledPath 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 p = if closed p then pathOutline' (begin p) (segments p ++ [Line $ begin p]) else pathOutline' (begin p) (segments p) pathOutline' (Point x0 y0) (Line (Point x1 y1) : ps) = [x0,y0,x1,y1] ++ pathOutline' (Point x1 y1) ps pathOutline' (Point x0 y0) (EndPoint (Point x1 y1) : ps) = pathOutline' (Point x1 y1) ps pathOutline' a (Spline c0 c1 b:ps) = splineVertices 256 a c0 c1 b ++ pathOutline' b ps@@ -122,14 +125,14 @@ where log2 x = logDouble x / logDouble 2 wf = w hf = h- + getFreeTexture e = if texture_whitelist e /= [] then (e{ texture_whitelist = tail $ texture_whitelist e }, head (texture_whitelist e))- else (e{ texture_greylist = c' }, t) + else (e{ texture_greylist = c' }, t) where ((_,t),c') = Cache.free . texture_greylist $ e- - - +++ compileText e txt | cachetxt txt `Cache.member` texture_greylist e = do let Point x y = bottomleft txt@@ -138,8 +141,8 @@ return ( e{ texture_greylist = c' }, CompiledImage txt x y w h tex (fromIntegral (sig txt))) | otherwise = do- let (e', tex) = getFreeTexture e - + let (e', tex) = getFreeTexture e+ layout <- layoutEmpty (context e') layoutSetMarkup layout . Pretty.render . str $ txt layoutSetAlignment layout . align $ txt@@ -147,7 +150,7 @@ layoutSetWidth layout . wrapwidth $ txt layoutSetWrap layout . wrapmode $ txt layoutSetIndent layout . indent $ txt- (PangoRectangle _ _ _ _, PangoRectangle ex ey ew eh) <- layoutGetExtents layout+ (PangoRectangle ex ey ew eh, _) <- layoutGetExtents layout let (po2w,po2h) = nearestPowerOfTwo ew eh potw = 2 ^ (max 0 $ ceiling po2w) poth = 2 ^ (max 0 $ ceiling po2h)@@ -166,16 +169,21 @@ liftIO $ layoutContextChanged layout Cairo.save Cairo.translate (-ex) (-ey)+ when (isJust . backgroundcolour $ txt) $ do+ let (br,bg,bb,ba) = colourToTuple . fromJust . backgroundcolour $ txt in Cairo.setSourceRGBA br bg bb ba+ Cairo.rectangle 0 0 w h+ Cairo.fill+ Cairo.translate 2 2 let (fr,fg,fb,fa) = colourToTuple . afillRGBA $ state (sr,sg,sb,sa) = colourToTuple . astrokeRGBA $ state state = attribs txt- when (afilled state) $ do - Cairo.setSourceRGBA fr fg fb fa - Cairo.showLayout layout + when (afilled state) $ do+ Cairo.setSourceRGBA fr fg fb fa+ Cairo.showLayout layout Cairo.fill when (aoutlined state) $ do Cairo.setSourceRGBA sr sg sb sa- Cairo.showLayout layout + Cairo.showLayout layout Cairo.stroke Cairo.restore Cairo.imageSurfaceGetData surf@@ -196,7 +204,7 @@ (unsafeForeignPtrToPtr (dataFrom textSurface))) return ( e'{ texdims = Map.insert tex (w, h) (texdims e')- , texture_greylist = Cache.put (cachetxt txt) tex (texture_greylist e') + , texture_greylist = Cache.put (cachetxt txt) tex (texture_greylist e') } , CompiledImage txt x y w h tex (fromIntegral (sig txt))) @@ -208,36 +216,41 @@ return ( e{texture_greylist = c'} , CompiledImage img x y w h tex (fromIntegral (sig img))) | otherwise = 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 (e', tex) = getFreeTexture e+ pbuf <- try $ case dimensions img of+ (Left (Point x y)) -> Gtk.pixbufNewFromFile (filename img) + (Right (Rect x y w h)) -> Gtk.pixbufNewFromFileAtScale (filename img) (round w) (round h) (preserveaspect img) - GL.textureBinding GL.Texture2D $= Just tex- 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+ let exceptionHandler = flip $ either (\_ -> trace ("Image failed to load" ++ filename img) $ return (e, CompiledImage img x y 1 1 (GL.TextureObject 0) 0)) - 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)))+ exceptionHandler pbuf $ \pb -> do + (w,h,potw,poth,channels,buffer) <- copydata pb - let (w',h') = case dimensions img of- Left _ -> (fromIntegral w, fromIntegral h)- Right (Rect _ _ w0 h0) -> (w0,h0)+ let (e', tex) = getFreeTexture e - return ( e'{ texdims = Map.insert tex (w',h') (texdims e') - , texture_greylist = Cache.put (cacheimg img) tex (texture_greylist e')- }- , CompiledImage img x y w' h' tex (fromIntegral (sig img)))+ GL.textureBinding GL.Texture2D $= Just tex+ 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+ (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 (w',h') = case dimensions img of+ Left _ -> (fromIntegral w, fromIntegral h)+ Right (Rect _ _ w0 h0) -> (w0,h0)++ return ( e'{ texdims = Map.insert tex (w',h') (texdims e')+ , texture_greylist = Cache.put (cacheimg img) tex (texture_greylist e')+ }+ , CompiledImage img x y w' h' tex (fromIntegral (sig img))) where (x, y) = case dimensions img of Left (Point x0 y0) -> (x0, y0) Right (Rect x0 y0 _ _) -> (x0,y0)
Graphics/Rendering/Hieroglyph/OpenGL/Render.hs view
@@ -74,19 +74,15 @@ GL.textureBinding GL.Texture2D $= Nothing loadAttrs attrs - GL.lineSmooth $= GL.Disabled- GL.polygonSmooth $= GL.Disabled GL.color . colourToGL . afillRGBA $ attrs when (afilled attrs) . GL.withName (GL.Name iid) .- GL.renderPrimitive GL.Quads .+ GL.renderPrimitive GL.TriangleFan . mapM_ GL.vertex $ take 4 vertices GL.color . colourToGL . astrokeRGBA $ attrs- GL.lineSmooth $= GL.Enabled- GL.polygonSmooth $= GL.Enabled when (aoutlined attrs) . GL.withName (GL.Name iid) .@@ -100,9 +96,9 @@ ,GL.Vertex3 (x+w) (y+h) z ,GL.Vertex3 x (y+h) z ,GL.Vertex3 x y z]- - ++ renderCompiledGeometry z obj@(CompiledImage original x y w h tex iid) = do GL.textureFunction $= GL.Replace GL.color $ GL.Color4 1 1 1 (1::Double)@@ -111,9 +107,6 @@ GL.texture GL.Texture2D $= GL.Enabled GL.textureFunction $= GL.Replace - GL.lineSmooth $= GL.Disabled- GL.polygonSmooth $= GL.Disabled- GL.withName (GL.Name iid) . GL.renderPrimitive GL.Quads $ do GL.texCoord $ GL.TexCoord2 0 (1::Double) GL.vertex $ GL.Vertex3 x y z@@ -125,12 +118,10 @@ GL.vertex $ GL.Vertex3 x (y+h) z GL.flush - GL.lineSmooth $= GL.Enabled- GL.polygonSmooth $= GL.Enabled renderObject z obj | afilled (attribs . original $ obj) = GL.preservingMatrix $ do- + GL.textureBinding GL.Texture2D $= Nothing loadAttrs (attribs . original $ obj ) GL.color . colourToGL . afillRGBA . attribs . original $ obj@@ -138,7 +129,7 @@ GL.color . colourToGL . astrokeRGBA . attribs . original $ obj when (aoutlined (attribs . original $ obj)) $ (GL.withName (GL.Name (uid obj)) . GL.renderPrimitive GL.LineStrip . mapM_ GL.vertex . verticesFrom . drop 2 $ vertices obj) | otherwise = GL.preservingMatrix $ do- + loadAttrs (attribs . original $ obj) GL.color . colourToGL . astrokeRGBA . attribs . original $ obj GL.withName (GL.Name (uid obj)) . GL.renderPrimitive GL.LineStrip . mapM_ GL.vertex . verticesFrom . drop 2 $ vertices obj@@ -155,8 +146,6 @@ GL.translate $ GL.Vector3 (atranslatex attrs) (atranslatey attrs) 0 GL.scale (ascalex attrs) (ascaley attrs) 1 GL.rotate (arotation attrs) $ GL.Vector3 0 0 1- GL.lineSmooth $= GL.Enabled- GL.polygonSmooth $= GL.Enabled -- TODO support line cap -- TODO support line join -- TODO support miter limit@@ -181,9 +170,10 @@ GL.depthFunc $= Just GL.Less GL.blend $= GL.Enabled GL.blendFunc $= (GL.SrcAlpha, GL.OneMinusSrcAlpha)- GL.lineSmooth $= GL.Enabled- GL.polygonSmooth $= GL.Enabled- GL.pointSmooth $= GL.Enabled+ GL.lineSmooth $= GL.Disabled+ GL.polygonSmooth $= GL.Disabled+ GL.pointSmooth $= GL.Disabled+ GL.multisample $= GL.Enabled r' <- renderObjects [1::Double,2..] (sort geo) runtime Gtk.glDrawableSwapBuffers drawable return r'{ texture_blacklist = [] }
Graphics/Rendering/Hieroglyph/Primitives.hs view
@@ -187,6 +187,7 @@ , attribs :: Attributes , spacing :: Double , sig :: Int+ , backgroundcolour :: Maybe (AlphaColour Double) } -- | Not a primitive shape, exactly, but the union of several primitives. No order is implied in a union, merely that the areas that intersect are | Union@@ -274,7 +275,7 @@ 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 (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)@@ -285,7 +286,7 @@ primitiveOrdering (Arc _ _ _ _ _ _ _) = 1 primitiveOrdering (Path _ _ _ _ _) = 2 primitiveOrdering (Rectangle _ _ _ _ _) = 3-primitiveOrdering (Text _ _ _ _ _ _ _ _ _ _) = 4+primitiveOrdering (Text _ _ _ _ _ _ _ _ _ _ _) = 4 primitiveOrdering (Union _ _ _) = 5 primitiveOrdering (Image _ _ _ _ _) = 6 primitiveOrdering (Hidden _ _) = 7@@ -433,7 +434,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 Nothing WrapWholeWords False 0 plain{ afilled=True } 0 0+string = sign $ Text empty origin AlignLeft Nothing WrapWholeWords False 0 plain{ afilled=True } 0 0 Nothing compound :: Primitive -- ^ An outlined compound object compound = sign $ Union [] plain 0
Graphics/Rendering/Hieroglyph/Visual.hs view
@@ -54,7 +54,7 @@ -- | 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) ++ (primitives that)- where maxlev = maximum . map (layer . attribs) . primitives $ that+ where maxlev = if length (primitives that) > 0 then maximum . map (layer . attribs) . primitives $ that else maximum . map (layer . attribs) . primitives $ this -- | Declare that a Visual doesn't occlude another Visual beside :: (Visual t, Visual u) => t -> u -> BaseVisual
Hieroglyph.cabal view
@@ -1,5 +1,5 @@ name: Hieroglyph-version: 3.1+version: 3.2 cabal-version: >=1.2 build-type: Simple license: BSD3